From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 8 Nov 2017 23:47:26 +0100
Subject: Use a better project structure

---
 client/src/Component/Button.hs   | 53 +++++++++++++++++++++++
 client/src/Component/Input.hs    | 34 +++++++++++++++
 client/src/Icon.hs               | 44 ++++++++++++++++++++
 client/src/Main.hs               | 40 ++++++++++++++++++
 client/src/View/App.hs           | 44 ++++++++++++++++++++
 client/src/View/Header.hs        | 86 ++++++++++++++++++++++++++++++++++++++
 client/src/View/Payment.hs       | 33 +++++++++++++++
 client/src/View/Payment/Table.hs | 90 ++++++++++++++++++++++++++++++++++++++++
 client/src/View/SignIn.hs        | 86 ++++++++++++++++++++++++++++++++++++++
 9 files changed, 510 insertions(+)
 create mode 100644 client/src/Component/Button.hs
 create mode 100644 client/src/Component/Input.hs
 create mode 100644 client/src/Icon.hs
 create mode 100644 client/src/Main.hs
 create mode 100644 client/src/View/App.hs
 create mode 100644 client/src/View/Header.hs
 create mode 100644 client/src/View/Payment.hs
 create mode 100644 client/src/View/Payment/Table.hs
 create mode 100644 client/src/View/SignIn.hs

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
new file mode 100644
index 0000000..f21798c
--- /dev/null
+++ b/client/src/Component/Button.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Component.Button
+  ( ButtonIn(..)
+  , buttonInDefault
+  , ButtonOut(..)
+  , button
+  ) where
+
+import qualified Data.Map as M
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget, Event)
+import qualified Reflex.Dom as R
+
+import qualified Icon
+
+data ButtonIn t m = ButtonIn
+  { _buttonIn_class :: Text
+  , _buttonIn_content :: m ()
+  , _buttonIn_waiting :: Event t Bool
+  }
+
+buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m
+buttonInDefault = ButtonIn
+  { _buttonIn_class = ""
+  , _buttonIn_content = R.blank
+  , _buttonIn_waiting = R.never
+  }
+
+data ButtonOut t = ButtonOut
+  { _buttonOut_clic :: Event t ()
+  }
+
+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))
+  (e, _) <- R.elDynAttr' "button" attr $ do
+    Icon.loading
+    R.divClass "content" $ _buttonIn_content buttonIn
+  return $ ButtonOut
+    { _buttonOut_clic = R.domEvent R.Click e
+    }
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
new file mode 100644
index 0000000..7111630
--- /dev/null
+++ b/client/src/Component/Input.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Component.Input
+  ( InputIn(..)
+  , InputOut(..)
+  , input
+  ) where
+
+import Data.Text (Text)
+import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:))
+import qualified Reflex.Dom as R
+
+data InputIn t a b = InputIn
+  { _inputIn_reset :: Event t a
+  , _inputIn_placeHolder :: Text
+  }
+
+data InputOut t = InputOut
+  { _inputOut_value :: Dynamic t Text
+  , _inputOut_enter :: Event t ()
+  }
+
+input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t)
+input inputIn = do
+  let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn)
+  let value = fmap (const "") (_inputIn_reset inputIn)
+  textInput <- R.textInput $ R.def & R.attributes .~ placeHolder
+                                   & R.setValue .~ value
+  let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+  return $ InputOut
+    { _inputOut_value = R._textInput_value textInput
+    , _inputOut_enter = enter
+    }
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
new file mode 100644
index 0000000..7223def
--- /dev/null
+++ b/client/src/Icon.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Icon
+  ( loading
+  , signOut
+  , clone
+  , edit
+  , delete
+  ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+loading :: forall t m. MonadWidget t m => m ()
+loading =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
+    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
+
+signOut :: forall t m. MonadWidget t m => m ()
+signOut =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
+
+clone :: forall t m. MonadWidget t m => m ()
+clone =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
+
+edit :: forall t m. MonadWidget t m => m ()
+edit =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
+
+delete :: forall t m. MonadWidget t m => m ()
+delete =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+
+svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
+svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/Main.hs b/client/src/Main.hs
new file mode 100644
index 0000000..1f167d4
--- /dev/null
+++ b/client/src/Main.hs
@@ -0,0 +1,40 @@
+module Main
+  ( main
+  ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LB
+import Data.JSString.Text (textFromJSString)
+import qualified Data.Text.Encoding as T
+import qualified GHCJS.DOM as Dom
+import qualified GHCJS.DOM.NonElementParentNode as Dom
+import GHCJS.DOM.Types (JSM, Element, JSString)
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(InitEmpty))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+import qualified View.App as App
+
+main :: JSM ()
+main = do
+  initResult <- readInit
+  App.widget initResult
+
+readInit :: JSM InitResult
+readInit = do
+  document <- Dom.currentDocumentUnchecked
+  initNode <- Dom.getElementById document "init"
+  case initNode of
+    Just node -> do
+      text <- textFromJSString <$> js_getInnerText node
+      return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
+        Just init -> init
+        Nothing -> initParseError
+    _ ->
+      return initParseError
+  where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
+
+foreign import javascript unsafe "$1[\"innerText\"]"
+  js_getInnerText :: Element -> IO JSString
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
new file mode 100644
index 0000000..1466811
--- /dev/null
+++ b/client/src/View/App.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.App
+  ( widget
+  ) where
+
+import qualified Reflex.Dom as R
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(..))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+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
+
+widget :: InitResult -> IO ()
+widget initResult =
+  R.mainWidget $ do
+    headerOut <- Header.view $ HeaderIn
+      { _headerIn_initResult = initResult
+      }
+
+    let signOut = Header._headerOut_signOut headerOut
+
+        initialContent = case initResult of
+          InitSuccess initSuccess -> do
+            _ <- Payment.widget $ PaymentIn
+              { _paymentIn_init = initSuccess
+              }
+            return ()
+          InitEmpty result ->
+            SignIn.view result
+
+        signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
+
+    _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+
+    R.blank
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
new file mode 100644
index 0000000..705e054
--- /dev/null
+++ b/client/src/View/Header.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Header
+  ( view
+  , HeaderIn(..)
+  , 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 Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (InitResult(..), Init(..), User(..))
+import qualified Common.Model as CM
+
+import Component.Button (ButtonIn(..))
+import qualified Component.Button as Component
+import qualified Icon
+
+data HeaderIn = HeaderIn
+  { _headerIn_initResult :: InitResult
+  }
+
+data HeaderOut t = HeaderOut
+  { _headerOut_signOut :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
+view headerIn =
+  R.el "header" $ do
+
+    R.divClass "title" $
+      R.text $ Message.get Key.App_Title
+
+    signOut <- nameSignOut $ _headerIn_initResult headerIn
+
+    return $ HeaderOut
+      { _headerOut_signOut = signOut
+      }
+
+nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
+nameSignOut initResult = case initResult of
+  (InitSuccess init) -> do
+    rec
+      attr <- R.holdDyn
+        (M.singleton "class" "nameSignOut")
+        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+      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
+        signOutButton
+
+    return signOut
+  _ ->
+    return R.never
+
+signOutButton :: forall t m. MonadWidget t m => m (Event t ())
+signOutButton = do
+  rec
+    signOut <- Component.button $ ButtonIn
+      { Component._buttonIn_class = "signOut item"
+      , Component._buttonIn_content = Icon.signOut
+      , Component._buttonIn_waiting = waiting
+      }
+    let signOutClic = Component._buttonOut_clic signOut
+        waiting = R.leftmost
+          [ fmap (const True) signOutClic
+          , fmap (const False) signOutSuccess
+          ]
+    signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime)
+
+  return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess
+
+  where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
+        askSignOut signOut =
+          fmap getResult <$> R.performRequestAsync xhrRequest
+          where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
+                getResult = (== 200) . R._xhrResponse_status
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
new file mode 100644
index 0000000..e80790b
--- /dev/null
+++ b/client/src/View/Payment.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment
+  ( widget
+  , PaymentIn(..)
+  , PaymentOut(..)
+  ) where
+
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Init)
+
+import View.Payment.Table (TableIn(..))
+import qualified View.Payment.Table as Table
+
+data PaymentIn = PaymentIn
+  { _paymentIn_init :: Init
+  }
+
+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
+      }
+    return $ PaymentOut {}
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
new file mode 100644
index 0000000..f3eb9a7
--- /dev/null
+++ b/client/src/View/Payment/Table.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment.Table
+  ( widget
+  , TableIn(..)
+  , 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 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 qualified Common.View.Format as Format
+
+import qualified Icon
+
+data TableIn = TableIn
+  { _tableIn_init :: Init
+  }
+
+data TableOut = TableOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => TableIn -> m TableOut
+widget tableIn = do
+  R.divClass "table" $
+    R.divClass "lines" $ do
+      R.divClass "header" $ do
+        R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
+        R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
+        R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
+        R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
+        R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
+        R.divClass "cell" $ R.blank
+        R.divClass "cell" $ R.blank
+        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)
+  return $ TableOut {}
+
+paymentRow :: forall t m. MonadWidget t m => Init -> 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 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.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.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
+
+findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
+findCategory categories paymentCategories paymentName = do
+  paymentCategory <- L.find
+    ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
+    paymentCategories
+  L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
new file mode 100644
index 0000000..e164ee7
--- /dev/null
+++ b/client/src/View/SignIn.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# 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 Common.Message as Message
+import qualified Common.Message.Key as Key
+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
+
+view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
+view result =
+  R.divClass "signIn" $ do
+    rec
+      input <- Component.input $ InputIn
+        { _inputIn_reset = R.ffilter Either.isRight signInResult
+        , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+        }
+
+      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
+
+      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
+        [ fmap (const True) userWantsEmailValidation
+        , fmap (const False) signInResult
+        ]
+
+      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
+
+      let validatedEmail = R.tagPromptlyDyn
+            (_inputOut_value input)
+            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
+
+      let waiting = R.leftmost
+            [ fmap (const True) validatedEmail
+            , fmap (const False) signInResult
+            ]
+
+      button <- Component.button $ ButtonIn
+        { _buttonIn_class = ""
+        , _buttonIn_content = R.text (Message.get Key.SignIn_Button)
+        , _buttonIn_waiting = waiting
+        }
+
+      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
+
+    showSignInResult result signInResult
+
+askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
+askSignIn email =
+  fmap getResult <$> R.performRequestAsync xhrRequest
+  where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email
+        getResult response =
+          case R._xhrResponse_responseText response of
+            Just key ->
+              if R._xhrResponse_status response == 200 then Right key else Left key
+            _ -> Left "NoKey"
+
+showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
+showSignInResult result signInResult = do
+  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+  R.blank
+
+  where showInitResult (Left error) = showError error
+        showInitResult (Right (Just success)) = showSuccess success
+        showInitResult (Right Nothing) = R.blank
+
+        showResult (Left error) = showError error
+        showResult (Right success) = showSuccess success
+
+        showError = R.divClass "error" . R.text
+        showSuccess = R.divClass "success" . R.text
-- 
cgit v1.2.3


From 213cf7ede058b781fc957de2cd9f6a5988c08004 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 12 Nov 2017 22:58:23 +0100
Subject: Add mocked pages

---
 client/src/Icon.hs               | 58 ++++++++++++++++++++++++++++------------
 client/src/Main.hs               | 15 +++++------
 client/src/View/Payment.hs       |  7 ++++-
 client/src/View/Payment/Pages.hs | 42 +++++++++++++++++++++++++++++
 4 files changed, 96 insertions(+), 26 deletions(-)
 create mode 100644 client/src/View/Payment/Pages.hs

(limited to 'client/src')

diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index 7223def..6b2749a 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -2,11 +2,15 @@
 {-# LANGUAGE OverloadedStrings         #-}
 
 module Icon
-  ( loading
-  , signOut
-  , clone
-  , edit
+  ( clone
   , delete
+  , edit
+  , loading
+  , doubleLeft
+  , doubleLeftBar
+  , doubleRight
+  , doubleRightBar
+  , signOut
   ) where
 
 import Data.Map (Map)
@@ -15,30 +19,50 @@ import Data.Text (Text)
 import Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-loading :: forall t m. MonadWidget t m => m ()
-loading =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
-    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
-
-signOut :: forall t m. MonadWidget t m => m ()
-signOut =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
-
 clone :: forall t m. MonadWidget t m => m ()
 clone =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
     svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
 
+delete :: forall t m. MonadWidget t m => m ()
+delete =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+
+doubleLeft :: forall t m. MonadWidget t m => m ()
+doubleLeft =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank
+
+doubleLeftBar :: forall t m. MonadWidget t m => m ()
+doubleLeftBar =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank
+
+doubleRight :: forall t m. MonadWidget t m => m ()
+doubleRight =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
+
+doubleRightBar :: forall t m. MonadWidget t m => m ()
+doubleRightBar =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
+
 edit :: forall t m. MonadWidget t m => m ()
 edit =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
     svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
 
-delete :: forall t m. MonadWidget t m => m ()
-delete =
+loading :: forall t m. MonadWidget t m => m ()
+loading =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
+    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
+
+signOut :: forall t m. MonadWidget t m => m ()
+signOut =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
 
 svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
 svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/Main.hs b/client/src/Main.hs
index 1f167d4..14f0fee 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -4,11 +4,13 @@ module Main
 
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as LB
-import Data.JSString.Text (textFromJSString)
+import qualified Data.JSString.Text as Dom
 import qualified Data.Text.Encoding as T
-import qualified GHCJS.DOM as Dom
-import qualified GHCJS.DOM.NonElementParentNode as Dom
-import GHCJS.DOM.Types (JSM, Element, JSString)
+import qualified JSDOM as Dom
+import qualified JSDOM.Generated.HTMLElement as Dom
+import qualified JSDOM.Generated.NonElementParentNode as Dom
+import JSDOM.Types (JSM, HTMLElement(..))
+import qualified JSDOM.Types as Dom
 import Prelude hiding (init, error)
 
 import Common.Model (InitResult(InitEmpty))
@@ -28,13 +30,10 @@ readInit = do
   initNode <- Dom.getElementById document "init"
   case initNode of
     Just node -> do
-      text <- textFromJSString <$> js_getInnerText node
+      text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
       return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
         Just init -> init
         Nothing -> initParseError
     _ ->
       return initParseError
   where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
-
-foreign import javascript unsafe "$1[\"innerText\"]"
-  js_getInnerText :: Element -> IO JSString
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index e80790b..d1430c9 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -11,8 +11,10 @@ module View.Payment
 import Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-import Common.Model (Init)
+import Common.Model (Init(..))
 
+import View.Payment.Pages (PagesIn(..))
+import qualified View.Payment.Pages as Pages
 import View.Payment.Table (TableIn(..))
 import qualified View.Payment.Table as Table
 
@@ -30,4 +32,7 @@ widget paymentIn = do
     _ <- Table.widget $ TableIn
       { _tableIn_init = _paymentIn_init paymentIn
       }
+    _ <- 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
new file mode 100644
index 0000000..f9a2b4e
--- /dev/null
+++ b/client/src/View/Payment/Pages.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment.Pages
+  ( widget
+  , PagesIn(..)
+  , PagesOut(..)
+  ) where
+
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Payment(..))
+
+import qualified Icon
+
+data PagesIn = PagesIn
+  { _pagesIn_payments :: [Payment]
+  }
+
+data PagesOut = PagesOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut
+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
-- 
cgit v1.2.3


From 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 13 Nov 2017 23:56:40 +0100
Subject: Setup stylish-haskell

---
 client/src/Component.hs          |   4 ++
 client/src/Component/Button.hs   |  17 +++----
 client/src/Component/Input.hs    |   9 ++--
 client/src/Icon.hs               |  11 ++---
 client/src/Main.hs               |  28 +++++------
 client/src/View/App.hs           |  23 +++++----
 client/src/View/Header.hs        |  27 +++++------
 client/src/View/Payment.hs       |  29 +++++------
 client/src/View/Payment/Pages.hs |  57 +++++++++++++---------
 client/src/View/Payment/Table.hs | 102 ++++++++++++++++++++++-----------------
 client/src/View/SignIn.hs        |  36 +++++++-------
 11 files changed, 183 insertions(+), 160 deletions(-)
 create mode 100644 client/src/Component.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
new file mode 100644
index 0000000..4c9541b
--- /dev/null
+++ b/client/src/Component.hs
@@ -0,0 +1,4 @@
+module Component (module X) where
+
+import           Component.Button as X
+import           Component.Input  as X
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index f21798c..9499045 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Component.Button
   ( ButtonIn(..)
@@ -8,17 +7,17 @@ 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 (MonadWidget, Event)
-import qualified Reflex.Dom as R
+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 Icon
 
 data ButtonIn t m = ButtonIn
-  { _buttonIn_class :: Text
+  { _buttonIn_class   :: Text
   , _buttonIn_content :: m ()
   , _buttonIn_waiting :: Event t Bool
   }
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 7111630..c3864b4 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Component.Input
   ( InputIn(..)
@@ -7,12 +6,12 @@ module Component.Input
   , input
   ) where
 
-import Data.Text (Text)
-import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:))
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:))
 import qualified Reflex.Dom as R
 
 data InputIn t a b = InputIn
-  { _inputIn_reset :: Event t a
+  { _inputIn_reset       :: Event t a
   , _inputIn_placeHolder :: Text
   }
 
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index 6b2749a..cd5a0b4 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Icon
   ( clone
@@ -13,10 +12,10 @@ module Icon
   , signOut
   ) where
 
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Text (Text)
-import Reflex.Dom (MonadWidget)
+import           Data.Map   (Map)
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import           Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
 clone :: forall t m. MonadWidget t m => m ()
diff --git a/client/src/Main.hs b/client/src/Main.hs
index 14f0fee..cbc881c 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -2,22 +2,22 @@ module Main
   ( main
   ) where
 
-import qualified Data.Aeson as Aeson
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.JSString.Text as Dom
-import qualified Data.Text.Encoding as T
-import qualified JSDOM as Dom
-import qualified JSDOM.Generated.HTMLElement as Dom
+import qualified Data.Aeson                           as Aeson
+import qualified Data.ByteString.Lazy                 as LB
+import qualified Data.JSString.Text                   as Dom
+import qualified Data.Text.Encoding                   as T
+import qualified JSDOM                                as Dom
+import qualified JSDOM.Generated.HTMLElement          as Dom
 import qualified JSDOM.Generated.NonElementParentNode as Dom
-import JSDOM.Types (JSM, HTMLElement(..))
-import qualified JSDOM.Types as Dom
-import Prelude hiding (init, error)
+import           JSDOM.Types                          (HTMLElement (..), JSM)
+import qualified JSDOM.Types                          as Dom
+import           Prelude                              hiding (error, init)
 
-import Common.Model (InitResult(InitEmpty))
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
+import qualified Common.Message                       as Message
+import qualified Common.Message.Key                   as Key
+import           Common.Model                         (InitResult (InitEmpty))
 
-import qualified View.App as App
+import qualified View.App                             as App
 
 main :: JSM ()
 main = do
@@ -33,7 +33,7 @@ readInit = do
       text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
       return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
         Just init -> init
-        Nothing -> initParseError
+        Nothing   -> initParseError
     _ ->
       return initParseError
   where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
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
-- 
cgit v1.2.3


From 42e94a45e26f40edc3ad71b1e77a4bf47c13fd3d Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 15 Nov 2017 23:50:44 +0100
Subject: Add dynamic pages

---
 client/src/Component/Button.hs       | 40 +++++++++++---------
 client/src/View/Header.hs            |  2 +-
 client/src/View/Payment/Constants.hs |  6 +++
 client/src/View/Payment/Pages.hs     | 71 +++++++++++++++++++++++-------------
 client/src/View/Payment/Table.hs     | 50 +++++++++++++------------
 client/src/View/SignIn.hs            |  2 +-
 6 files changed, 103 insertions(+), 68 deletions(-)
 create mode 100644 client/src/View/Payment/Constants.hs

(limited to 'client/src')

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
         }
-- 
cgit v1.2.3


From 7194cddb28656c721342c2ef604f9f9fb0692960 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 00:20:25 +0100
Subject: Show payment count and partition

- Also fixes exceedingPayer in back by using only punctual payments
---
 client/src/Component/Button.hs       |  2 --
 client/src/Component/Input.hs        |  2 --
 client/src/Icon.hs                   |  2 --
 client/src/Main.hs                   |  9 ++---
 client/src/Util/List.hs              | 13 +++++++
 client/src/View/App.hs               | 24 ++++++-------
 client/src/View/Header.hs            | 26 ++++++--------
 client/src/View/Payment.hs           | 22 ++++++------
 client/src/View/Payment/Constants.hs |  2 +-
 client/src/View/Payment/Header.hs    | 70 ++++++++++++++++++++++++++++++++++++
 client/src/View/Payment/Pages.hs     |  8 ++---
 client/src/View/Payment/Table.hs     | 28 +++++++--------
 client/src/View/SignIn.hs            | 32 ++++++++---------
 13 files changed, 152 insertions(+), 88 deletions(-)
 create mode 100644 client/src/Util/List.hs
 create mode 100644 client/src/View/Payment/Header.hs

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index c31cdc6..09c93cd 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Component.Button
   ( ButtonIn(..)
   , buttonInDefault
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index c3864b4..1923463 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Component.Input
   ( InputIn(..)
   , InputOut(..)
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index cd5a0b4..fbf5388 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Icon
   ( clone
   , delete
diff --git a/client/src/Main.hs b/client/src/Main.hs
index cbc881c..d55eefe 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -13,9 +13,8 @@ import           JSDOM.Types                          (HTMLElement (..), JSM)
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import qualified Common.Message                       as Message
-import qualified Common.Message.Key                   as Key
 import           Common.Model                         (InitResult (InitEmpty))
+import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
 
@@ -27,7 +26,8 @@ main = do
 readInit :: JSM InitResult
 readInit = do
   document <- Dom.currentDocumentUnchecked
-  initNode <- Dom.getElementById document "init"
+  initNode <- Dom.getElementById document ("init" :: Dom.JSString)
+
   case initNode of
     Just node -> do
       text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
@@ -36,4 +36,5 @@ readInit = do
         Nothing   -> initParseError
     _ ->
       return initParseError
-  where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
+
+  where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError)
diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
new file mode 100644
index 0000000..4e22ba8
--- /dev/null
+++ b/client/src/Util/List.hs
@@ -0,0 +1,13 @@
+module Util.List
+  ( groupBy
+  ) where
+
+import           Control.Arrow ((&&&))
+import           Data.Function (on)
+import qualified Data.List     as L
+
+groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
+groupBy f =
+  map (f . head &&& id)
+    . L.groupBy ((==) `on` f)
+    . L.sortBy (compare `on` f)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 442fa3e..64ca303 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -1,22 +1,18 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.App
   ( widget
   ) where
 
-import           Prelude            hiding (error, init)
-import qualified Reflex.Dom         as R
+import           Prelude      hiding (error, init)
+import qualified Reflex.Dom   as R
 
-import qualified Common.Message     as Message
-import qualified Common.Message.Key as Key
-import           Common.Model       (InitResult (..))
+import           Common.Model (InitResult (..))
+import qualified Common.Msg   as Msg
 
-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
+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 =
@@ -36,7 +32,7 @@ widget initResult =
           InitEmpty result ->
             SignIn.view result
 
-        signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
+        signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess)
 
     _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
 
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 7afd9bd..4c74383 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -1,25 +1,21 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Header
   ( view
   , HeaderIn(..)
   , HeaderOut(..)
   ) where
 
-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 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.Key as Key
-import           Common.Model       (Init (..), InitResult (..), User (..))
-import qualified Common.Model       as CM
+import           Common.Model     (Init (..), InitResult (..), User (..))
+import qualified Common.Model     as CM
+import qualified Common.Msg       as Msg
 
-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
@@ -35,7 +31,7 @@ view headerIn =
   R.el "header" $ do
 
     R.divClass "title" $
-      R.text $ Message.get Key.App_Title
+      R.text $ Msg.get Msg.App_Title
 
     signOut <- nameSignOut $ _headerIn_initResult headerIn
 
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f70c8cd..934f720 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -1,21 +1,20 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Payment
   ( widget
   , PaymentIn(..)
   , 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 (..), PagesOut (..))
-import qualified View.Payment.Pages as Pages
-import           View.Payment.Table (TableIn (..))
-import qualified View.Payment.Table as Table
+import           View.Payment.Header (HeaderIn (..))
+import qualified View.Payment.Header as Header
+import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
+import qualified View.Payment.Pages  as Pages
+import           View.Payment.Table  (TableIn (..))
+import qualified View.Payment.Table  as Table
 
 data PaymentIn = PaymentIn
   { _paymentIn_init :: Init
@@ -29,6 +28,9 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
 widget paymentIn = do
   R.divClass "payment" $ do
     rec
+      _ <- Header.widget $ HeaderIn
+        { _headerIn_init = _paymentIn_init $ paymentIn
+        }
       _ <- Table.widget $ TableIn
         { _tableIn_init = _paymentIn_init paymentIn
         , _tableIn_currentPage = _pagesOut_currentPage pagesOut
diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs
index ac2320a..028e328 100644
--- a/client/src/View/Payment/Constants.hs
+++ b/client/src/View/Payment/Constants.hs
@@ -3,4 +3,4 @@ module View.Payment.Constants
   ) where
 
 paymentsPerPage :: Int
-paymentsPerPage = 8
+paymentsPerPage = 7
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
new file mode 100644
index 0000000..67b4eb4
--- /dev/null
+++ b/client/src/View/Payment/Header.hs
@@ -0,0 +1,70 @@
+module View.Payment.Header
+  ( widget
+  , HeaderIn(..)
+  , HeaderOut(..)
+  ) where
+
+import qualified Data.List          as L hiding (groupBy)
+import           Data.Maybe         (fromMaybe)
+import qualified Data.Text          as T
+import           Prelude            hiding (init)
+import           Reflex.Dom         (MonadWidget)
+import qualified Reflex.Dom         as R
+
+import           Common.Model       (Currency, Frequency (..), Init (..),
+                                     Payment (..), User (..), UserId)
+import qualified Common.Msg         as Msg
+import qualified Common.View.Format as Format
+
+import qualified Util.List          as L
+
+data HeaderIn t = HeaderIn
+  { _headerIn_init    :: Init
+  }
+
+data HeaderOut = HeaderOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut
+widget headerIn =
+  R.divClass "header" $ do
+    infos payments users currency
+    return $ HeaderOut {}
+  where init = _headerIn_init headerIn
+        payments = _init_payments init
+        users = _init_users init
+        currency = _init_currency init
+
+infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m ()
+infos payments users currency =
+  R.divClass "infos" $ do
+    R.elClass "span" "total" $ do
+      R.text . Msg.get $ Msg.Payment_Worth
+        (T.intercalate " "
+          [ (Format.number paymentCount)
+          , if paymentCount > 1
+              then Msg.get Msg.Payment_Many
+              else Msg.get Msg.Payment_One
+          ])
+        (Format.price currency total)
+    R.elClass "span" "partition" . R.text $
+      T.intercalate ", "
+        . map (\(userId, userTotal) ->
+            Msg.get $ Msg.Payment_By
+              (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users)
+              (Format.price currency userTotal)
+          )
+        $ totalByUser
+
+  where punctualPayments = filter ((==) Punctual . _payment_frequency) payments
+        paymentCount = length punctualPayments
+        total = sum . map _payment_cost $ punctualPayments
+
+        totalByUser :: [(UserId, Int)]
+        totalByUser =
+          L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
+            . map (\(u, xs) -> (u, sum . map snd $ xs))
+            . L.groupBy fst
+            . map (\p -> (_payment_user p, _payment_cost p))
+            $ punctualPayments
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index f96cb8e..81555ab 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Payment.Pages
   ( widget
   , PagesIn(..)
@@ -11,7 +8,7 @@ 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           (Frequency (..), Payment (..))
 
 import           Component              (ButtonIn (..), ButtonOut (..))
 import qualified Component              as Component
@@ -48,7 +45,8 @@ widget pagesIn = do
       { _pagesOut_currentPage = currentPage
       }
 
-    where maxPage = ceiling $ (toRational . length . _pagesIn_payments $ pagesIn) / toRational Constants.paymentsPerPage
+    where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn
+          maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage
           pageEvent = R.switchPromptlyDyn . fmap R.leftmost
 
 range :: Int -> Int -> [Int]
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 5c0b709..d8093a5 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecursiveDo       #-}
-
 module View.Payment.Table
   ( widget
   , TableIn(..)
@@ -15,11 +12,11 @@ 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 (..),
+import           Common.Model           (Category (..), Frequency (..),
+                                         Init (..), Payment (..),
                                          PaymentCategory (..), User (..))
 import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
 import qualified Common.Util.Text       as T
 import qualified Common.View.Format     as Format
 
@@ -40,11 +37,11 @@ widget tableIn = do
   _ <- R.divClass "table" $
     R.divClass "lines" $ do
       R.divClass "header" $ do
-        R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
-        R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
-        R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
-        R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
-        R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
+        R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
+        R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
+        R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User
+        R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category
+        R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
@@ -58,10 +55,11 @@ widget tableIn = do
 getPaymentRange :: [Payment] -> Int -> [Payment]
 getPaymentRange payments currentPage =
   take Constants.paymentsPerPage
-  . drop ((currentPage - 1) * Constants.paymentsPerPage)
-  . reverse
-  . L.sortOn _payment_date
-  $ payments
+    . drop ((currentPage - 1) * Constants.paymentsPerPage)
+    . reverse
+    . L.sortOn _payment_date
+    . filter ((==) Punctual . _payment_frequency)
+    $ payments
 
 paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m ()
 paymentRow init payment =
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 1f5b900..69596d8 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,25 +1,21 @@
-{-# 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         (Event, MonadWidget)
-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.Key as Key
-import           Common.Model       (SignIn (SignIn))
+import           Common.Model (SignIn (SignIn))
+import qualified Common.Msg   as Msg
 
-import           Component          (ButtonIn (..), ButtonOut (..),
-                                     InputIn (..), InputOut (..))
-import qualified Component          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 =
@@ -27,7 +23,7 @@ view result =
     rec
       input <- Component.input $ InputIn
         { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+        , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder
         }
 
       let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
@@ -50,7 +46,7 @@ view result =
 
       button <- Component.button $ ButtonIn
         { _buttonIn_class = R.constDyn ""
-        , _buttonIn_content = R.text (Message.get Key.SignIn_Button)
+        , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
         , _buttonIn_waiting = waiting
         }
 
-- 
cgit v1.2.3


From bab2c30addf8aaed85675e2b7f7b15c97c426f74 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Nov 2017 15:00:07 +0100
Subject: Add exceeding payer block

---
 client/src/Component/Button.hs    |  6 ----
 client/src/Icon.hs                |  4 +--
 client/src/View/Payment.hs        |  8 +++--
 client/src/View/Payment/Header.hs | 66 ++++++++++++++++++++++++++++-----------
 4 files changed, 55 insertions(+), 29 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 09c93cd..754b903 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -48,9 +48,3 @@ button buttonIn = do
   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/Icon.hs b/client/src/Icon.hs
index fbf5388..e04e2a8 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -58,8 +58,8 @@ loading =
 
 signOut :: forall t m. MonadWidget t m => m ()
 signOut =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
+  svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank
 
 svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
 svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 934f720..15892c4 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -4,6 +4,7 @@ module View.Payment
   , PaymentOut(..)
   ) where
 
+import           Prelude             hiding (init)
 import           Reflex.Dom          (MonadWidget)
 import qualified Reflex.Dom          as R
 
@@ -29,13 +30,14 @@ widget paymentIn = do
   R.divClass "payment" $ do
     rec
       _ <- Header.widget $ HeaderIn
-        { _headerIn_init = _paymentIn_init $ paymentIn
+        { _headerIn_init = init
         }
       _ <- Table.widget $ TableIn
-        { _tableIn_init = _paymentIn_init paymentIn
+        { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pagesOut
         }
       pagesOut <- Pages.widget $ PagesIn
-        { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn
+        { _pagesIn_payments = _init_payments init
         }
     return $ PaymentOut {}
+  where init = _paymentIn_init paymentIn
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 67b4eb4..3f2adc3 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -4,22 +4,29 @@ module View.Payment.Header
   , HeaderOut(..)
   ) where
 
-import qualified Data.List          as L hiding (groupBy)
-import           Data.Maybe         (fromMaybe)
-import qualified Data.Text          as T
-import           Prelude            hiding (init)
-import           Reflex.Dom         (MonadWidget)
-import qualified Reflex.Dom         as R
+import           Control.Monad          (forM_)
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.List              as L hiding (groupBy)
+import           Data.Maybe             (fromMaybe)
+import qualified Data.Text              as T
+import qualified Data.Time              as Time
+import           Prelude                hiding (init)
+import           Reflex.Dom             (MonadWidget)
+import qualified Reflex.Dom             as R
 
-import           Common.Model       (Currency, Frequency (..), Init (..),
-                                     Payment (..), User (..), UserId)
-import qualified Common.Msg         as Msg
-import qualified Common.View.Format as Format
+import           Common.Model           (Currency, ExceedingPayer (..),
+                                         Frequency (..), Income (..), Init (..),
+                                         Payment (..), User (..), UserId)
+import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
+import qualified Common.View.Format     as Format
 
-import qualified Util.List          as L
+import           Component              (ButtonIn (..))
+import qualified Component              as Component
+import qualified Util.List              as L
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init    :: Init
+  { _headerIn_init :: Init
   }
 
 data HeaderOut = HeaderOut
@@ -29,13 +36,37 @@ data HeaderOut = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut
 widget headerIn =
   R.divClass "header" $ do
+    payerAndAdd incomes payments users currency
     infos payments users currency
     return $ HeaderOut {}
   where init = _headerIn_init headerIn
-        payments = _init_payments init
+        incomes = _init_incomes init
+        payments = filter ((==) Punctual . _payment_frequency) (_init_payments init)
         users = _init_users init
         currency = _init_currency init
 
+payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
+payerAndAdd incomes payments users currency = do
+  time <- liftIO Time.getCurrentTime
+  R.divClass "payerAndAdd" $ do
+    R.divClass "exceedingPayers" $
+      forM_
+        (CM.getExceedingPayers time users incomes payments)
+        (\p ->
+          R.elClass "span" "exceedingPayer" $ do
+            R.elClass "span" "userName" $
+              R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users
+            R.elClass "span" "amount" $ do
+              R.text "+ "
+              R.text . Format.price currency $ _exceedingPayer_amount p
+        )
+    _ <- Component.button $ ButtonIn
+      { _buttonIn_class = R.constDyn "addPayment"
+      , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
+      , _buttonIn_waiting = R.never
+      }
+    return ()
+
 infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m ()
 infos payments users currency =
   R.divClass "infos" $ do
@@ -52,14 +83,13 @@ infos payments users currency =
       T.intercalate ", "
         . map (\(userId, userTotal) ->
             Msg.get $ Msg.Payment_By
-              (fromMaybe "" . fmap _user_name . L.find ((==) userId . _user_id) $ users)
+              (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
               (Format.price currency userTotal)
           )
         $ totalByUser
 
-  where punctualPayments = filter ((==) Punctual . _payment_frequency) payments
-        paymentCount = length punctualPayments
-        total = sum . map _payment_cost $ punctualPayments
+  where paymentCount = length payments
+        total = sum . map _payment_cost $ payments
 
         totalByUser :: [(UserId, Int)]
         totalByUser =
@@ -67,4 +97,4 @@ infos payments users currency =
             . map (\(u, xs) -> (u, sum . map snd $ xs))
             . L.groupBy fst
             . map (\p -> (_payment_user p, _payment_cost p))
-            $ punctualPayments
+            $ payments
-- 
cgit v1.2.3


From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 28 Nov 2017 09:11:19 +0100
Subject: Add search for payments

---
 client/src/Component/Input.hs     | 57 ++++++++++++++++++++++++++++-----------
 client/src/Icon.hs                |  6 +++++
 client/src/View/Payment.hs        | 26 +++++++++++++-----
 client/src/View/Payment/Header.hs | 25 ++++++++++++-----
 client/src/View/Payment/Pages.hs  | 37 ++++++++++++++-----------
 client/src/View/Payment/Table.hs  |  9 +++----
 client/src/View/SignIn.hs         |  2 +-
 7 files changed, 112 insertions(+), 50 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 1923463..7eec7d0 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -4,13 +4,19 @@ module Component.Input
   , input
   ) where
 
-import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, 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           Component.Button (ButtonIn (..), ButtonOut (..))
+import qualified Component.Button as Button
+import qualified Icon
 
 data InputIn t a b = InputIn
-  { _inputIn_reset       :: Event t a
-  , _inputIn_placeHolder :: Text
+  { _inputIn_reset :: Event t a
+  , _inputIn_label :: Text
   }
 
 data InputOut t = InputOut
@@ -19,13 +25,34 @@ data InputOut t = InputOut
   }
 
 input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t)
-input inputIn = do
-  let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn)
-  let value = fmap (const "") (_inputIn_reset inputIn)
-  textInput <- R.textInput $ R.def & R.attributes .~ placeHolder
-                                   & R.setValue .~ value
-  let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
-  return $ InputOut
-    { _inputOut_value = R._textInput_value textInput
-    , _inputOut_enter = enter
-    }
+input inputIn =
+  R.divClass "textInput" $ do
+    rec
+      let resetValue = R.leftmost
+            [ fmap (const "") (_inputIn_reset inputIn)
+            , fmap (const "") (_buttonOut_clic reset)
+            ]
+
+          attributes = R.ffor value (\v ->
+            if T.null v then M.empty else M.singleton "class" "filled")
+
+          value =  R._textInput_value textInput
+
+      textInput <- R.textInput $ R.def
+        & R.attributes .~ attributes
+        & R.setValue .~ resetValue
+
+      R.el "label" $ R.text (_inputIn_label inputIn)
+
+      reset <- Button.button $ ButtonIn
+        { _buttonIn_class   = R.constDyn ""
+        , _buttonIn_content = Icon.cross
+        , _buttonIn_waiting = R.never
+        }
+
+    let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+
+    return $ InputOut
+      { _inputOut_value = value
+      , _inputOut_enter = enter
+      }
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index e04e2a8..555d928 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -1,5 +1,6 @@
 module Icon
   ( clone
+  , cross
   , delete
   , edit
   , loading
@@ -21,6 +22,11 @@ clone =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
     svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
 
+cross :: forall t m. MonadWidget t m => m ()
+cross =
+  svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank
+
 delete :: forall t m. MonadWidget t m => m ()
 delete =
   svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 15892c4..8aa4d38 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -8,9 +8,10 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (MonadWidget)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Init (..))
+import           Common.Model        (Frequency (..), Init (..), Payment (..))
+import           Common.Util.Text    as T
 
-import           View.Payment.Header (HeaderIn (..))
+import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
 import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
 import qualified View.Payment.Pages  as Pages
@@ -29,15 +30,26 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
 widget paymentIn = do
   R.divClass "payment" $ do
     rec
-      _ <- Header.widget $ HeaderIn
+      let init = _paymentIn_init paymentIn
+
+          filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual)
+
+          payments = fmap
+            (\s -> filter (filterPayment s) (_init_payments init))
+            (_headerOut_search header)
+
+      header <- Header.widget $ HeaderIn
         { _headerIn_init = init
         }
+
       _ <- Table.widget $ TableIn
         { _tableIn_init = init
-        , _tableIn_currentPage = _pagesOut_currentPage pagesOut
+        , _tableIn_currentPage = _pagesOut_currentPage pages
+        , _tableIn_payments = payments
         }
-      pagesOut <- Pages.widget $ PagesIn
-        { _pagesIn_payments = _init_payments init
+
+      pages <- Pages.widget $ PagesIn
+        { _pagesIn_payments = payments
         }
+
     return $ PaymentOut {}
-  where init = _paymentIn_init paymentIn
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 3f2adc3..f64f11d 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -8,10 +8,11 @@ import           Control.Monad          (forM_)
 import           Control.Monad.IO.Class (liftIO)
 import qualified Data.List              as L hiding (groupBy)
 import           Data.Maybe             (fromMaybe)
+import           Data.Text              (Text)
 import qualified Data.Text              as T
 import qualified Data.Time              as Time
 import           Prelude                hiding (init)
-import           Reflex.Dom             (MonadWidget)
+import           Reflex.Dom             (Dynamic, MonadWidget)
 import qualified Reflex.Dom             as R
 
 import           Common.Model           (Currency, ExceedingPayer (..),
@@ -21,7 +22,8 @@ import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
 
-import           Component              (ButtonIn (..))
+import           Component              (ButtonIn (..), InputIn (..),
+                                         InputOut (..))
 import qualified Component              as Component
 import qualified Util.List              as L
 
@@ -29,16 +31,19 @@ data HeaderIn t = HeaderIn
   { _headerIn_init :: Init
   }
 
-data HeaderOut = HeaderOut
-  {
+data HeaderOut t = HeaderOut
+  { _headerOut_search :: Dynamic t Text
   }
 
-widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut
+widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
     payerAndAdd incomes payments users currency
+    search <- searchLine
     infos payments users currency
-    return $ HeaderOut {}
+    return $ HeaderOut
+      { _headerOut_search = search
+      }
   where init = _headerIn_init headerIn
         incomes = _init_incomes init
         payments = filter ((==) Punctual . _payment_frequency) (_init_payments init)
@@ -98,3 +103,11 @@ infos payments users currency =
             . L.groupBy fst
             . map (\p -> (_payment_user p, _payment_cost p))
             $ payments
+
+searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text)
+searchLine =
+  R.divClass "searchLine" $
+    _inputOut_value <$> (Component.input $ InputIn
+      { _inputIn_reset = R.never
+      , _inputIn_label = Msg.get Msg.Search_Name
+      })
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 81555ab..dfd92c0 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -8,7 +8,7 @@ import qualified Data.Text              as T
 import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Frequency (..), Payment (..))
+import           Common.Model           (Payment (..))
 
 import           Component              (ButtonIn (..), ButtonOut (..))
 import qualified Component              as Component
@@ -16,52 +16,57 @@ import qualified Component              as Component
 import qualified Icon
 import qualified View.Payment.Constants as Constants
 
-data PagesIn = PagesIn
-  { _pagesIn_payments :: [Payment]
+data PagesIn t = PagesIn
+  { _pagesIn_payments :: Dynamic t [Payment]
   }
 
 data PagesOut t = PagesOut
   { _pagesOut_currentPage :: Dynamic t Int
   }
 
-widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t)
+widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
 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
+      firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
 
-      previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft
+      previousPageClic <- pageButton noCurrentPage (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))
+      pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p ->
+        pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p))
 
-      nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight
+      nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight
 
-      lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar
+      lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
 
     return $ PagesOut
       { _pagesOut_currentPage = currentPage
       }
 
-    where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn
-          maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage
+    where maxPage =
+            R.ffor (_pagesIn_payments pagesIn) (\payments ->
+              ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage
+            )
+
           pageEvent = R.switchPromptlyDyn . fmap R.leftmost
 
+          noCurrentPage = R.constDyn Nothing
+
 range :: Int -> Int -> [Int]
-range maxPage currentPage = [start..end]
+range currentPage maxPage = [start..end]
   where sidePages = 2
-        start = max 1 (currentPage - sidePages)
+        start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2))
         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 :: 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 <$> (Component.button $ ButtonIn
     { _buttonIn_class   = do
         cp <- currentPage
         p <- page
-        if cp == p then "page current" else "page"
+        if cp == Just p then "page current" else "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 d8093a5..0c3b769 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -12,8 +12,7 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Category (..), Frequency (..),
-                                         Init (..), Payment (..),
+import           Common.Model           (Category (..), Init (..), Payment (..),
                                          PaymentCategory (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
@@ -26,6 +25,7 @@ import qualified View.Payment.Constants as Constants
 data TableIn t = TableIn
   { _tableIn_init        :: Init
   , _tableIn_currentPage :: Dynamic t Int
+  , _tableIn_payments    :: Dynamic t [Payment]
   }
 
 data TableOut = TableOut
@@ -47,8 +47,8 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
       let init = _tableIn_init tableIn
           currentPage = _tableIn_currentPage tableIn
-          payments = _init_payments init
-          paymentRange = fmap (getPaymentRange payments) currentPage
+          payments = _tableIn_payments tableIn
+          paymentRange = getPaymentRange <$> payments <*> currentPage
       R.simpleList paymentRange (paymentRow init)
   return $ TableOut {}
 
@@ -58,7 +58,6 @@ getPaymentRange payments currentPage =
     . drop ((currentPage - 1) * Constants.paymentsPerPage)
     . reverse
     . L.sortOn _payment_date
-    . filter ((==) Punctual . _payment_frequency)
     $ payments
 
 paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m ()
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 69596d8..be6b152 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -23,7 +23,7 @@ view result =
     rec
       input <- Component.input $ InputIn
         { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder
+        , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
         }
 
       let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
-- 
cgit v1.2.3


From a4acc2e84158fa822f88a1d0bdddb470708b5809 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 3 Jan 2018 17:31:20 +0100
Subject: Modify weelky report and payment search interface

- Add payment balance in weekly report
- Show a message and hide pages when the search results in no results
- Go to page 1 when the search is updated / erased
---
 client/src/Component/Input.hs        |  2 +-
 client/src/Icon.hs                   |  8 ++---
 client/src/Util/Dom.hs               | 19 ++++++++++++
 client/src/View/Payment.hs           |  7 ++++-
 client/src/View/Payment/Constants.hs |  6 ----
 client/src/View/Payment/Pages.hs     | 51 +++++++++++++++++++------------
 client/src/View/Payment/Table.hs     | 59 +++++++++++++++++++++---------------
 client/src/View/SignIn.hs            |  4 +--
 8 files changed, 98 insertions(+), 58 deletions(-)
 create mode 100644 client/src/Util/Dom.hs
 delete mode 100644 client/src/View/Payment/Constants.hs

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 7eec7d0..24aac22 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -45,7 +45,7 @@ input inputIn =
       R.el "label" $ R.text (_inputIn_label inputIn)
 
       reset <- Button.button $ ButtonIn
-        { _buttonIn_class   = R.constDyn ""
+        { _buttonIn_class   = R.constDyn "reset"
         , _buttonIn_content = Icon.cross
         , _buttonIn_waiting = R.never
         }
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index 555d928..dae5e7f 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -29,8 +29,8 @@ cross =
 
 delete :: forall t m. MonadWidget t m => m ()
 delete =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank
 
 doubleLeft :: forall t m. MonadWidget t m => m ()
 doubleLeft =
@@ -54,8 +54,8 @@ doubleRightBar =
 
 edit :: forall t m. MonadWidget t m => m ()
 edit =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
+  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank
 
 loading :: forall t m. MonadWidget t m => m ()
 loading =
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
new file mode 100644
index 0000000..f3e9c88
--- /dev/null
+++ b/client/src/Util/Dom.hs
@@ -0,0 +1,19 @@
+module Util.Dom
+  ( divVisibleIf
+  , divClassVisibleIf
+  ) where
+
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
+divVisibleIf cond content = divClassVisibleIf cond "" content
+
+divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
+divClassVisibleIf cond className content =
+  R.elDynAttr
+    "div"
+    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
+    content
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 8aa4d38..f4aaf5c 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -38,6 +38,8 @@ widget paymentIn = do
             (\s -> filter (filterPayment s) (_init_payments init))
             (_headerOut_search header)
 
+          paymentsPerPage = 7
+
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
         }
@@ -46,10 +48,13 @@ widget paymentIn = do
         { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pages
         , _tableIn_payments = payments
+        , _tableIn_perPage = paymentsPerPage
         }
 
       pages <- Pages.widget $ PagesIn
-        { _pagesIn_payments = payments
+        { _pagesIn_total = length <$> payments
+        , _pagesIn_perPage = paymentsPerPage
+        , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header
         }
 
     return $ PaymentOut {}
diff --git a/client/src/View/Payment/Constants.hs b/client/src/View/Payment/Constants.hs
deleted file mode 100644
index 028e328..0000000
--- a/client/src/View/Payment/Constants.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module View.Payment.Constants
-  ( paymentsPerPage
-  ) where
-
-paymentsPerPage :: Int
-paymentsPerPage = 7
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index dfd92c0..55ceb9f 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -4,20 +4,20 @@ module View.Payment.Pages
   , PagesOut(..)
   ) where
 
-import qualified Data.Text              as T
-import           Reflex.Dom             (Dynamic, Event, 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           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
+import qualified Util.Dom   as Dom
 
 data PagesIn t = PagesIn
-  { _pagesIn_payments :: Dynamic t [Payment]
+  { _pagesIn_total   :: Dynamic t Int
+  , _pagesIn_perPage :: Int
+  , _pagesIn_reset   :: Event t ()
   }
 
 data PagesOut t = PagesOut
@@ -26,9 +26,29 @@ data PagesOut t = PagesOut
 
 widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
 widget pagesIn = do
+  currentPage <- Dom.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 ]
+      currentPage <- R.holdDyn 1 . R.leftmost $
+        [ firstPageClic
+        , previousPageClic
+        , pageClic
+        , nextPageClic
+        , lastPageClic
+        , (const 1) <$> reset
+        ]
 
       firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
 
@@ -41,17 +61,10 @@ widget pagesIn = do
 
       lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
 
-    return $ PagesOut
-      { _pagesOut_currentPage = currentPage
-      }
-
-    where maxPage =
-            R.ffor (_pagesIn_payments pagesIn) (\payments ->
-              ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage
-            )
+    return currentPage
 
+    where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
           pageEvent = R.switchPromptlyDyn . fmap R.leftmost
-
           noCurrentPage = R.constDyn Nothing
 
 range :: Int -> Int -> [Int]
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 0c3b769..a49be5c 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,28 +4,29 @@ 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             (Dynamic, MonadWidget)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Category (..), Init (..), Payment (..),
-                                         PaymentCategory (..), User (..))
-import qualified Common.Model           as CM
-import qualified Common.Msg             as Msg
-import qualified Common.Util.Text       as T
-import qualified Common.View.Format     as Format
+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           Common.Model       (Category (..), Init (..), Payment (..),
+                                     PaymentCategory (..), User (..))
+import qualified Common.Model       as CM
+import qualified Common.Msg         as Msg
+import qualified Common.Util.Text   as T
+import qualified Common.View.Format as Format
 
 import qualified Icon
-import qualified View.Payment.Constants as Constants
+import qualified Util.Dom           as Dom
 
 data TableIn t = TableIn
   { _tableIn_init        :: Init
   , _tableIn_currentPage :: Dynamic t Int
   , _tableIn_payments    :: Dynamic t [Payment]
+  , _tableIn_perPage     :: Int
   }
 
 data TableOut = TableOut
@@ -34,7 +35,8 @@ data TableOut = TableOut
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut
 widget tableIn = do
-  _ <- R.divClass "table" $
+  R.divClass "table" $ do
+
     R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
@@ -45,17 +47,24 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      let init = _tableIn_init tableIn
-          currentPage = _tableIn_currentPage tableIn
-          payments = _tableIn_payments tableIn
-          paymentRange = getPaymentRange <$> payments <*> currentPage
-      R.simpleList paymentRange (paymentRow init)
+      _ <- R.simpleList paymentRange (paymentRow init)
+      return ()
+
+    Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
+      R.text $ Msg.get Msg.Payment_Empty
+
   return $ TableOut {}
 
-getPaymentRange :: [Payment] -> Int -> [Payment]
-getPaymentRange payments currentPage =
-  take Constants.paymentsPerPage
-    . drop ((currentPage - 1) * Constants.paymentsPerPage)
+  where
+    init = _tableIn_init tableIn
+    currentPage = _tableIn_currentPage tableIn
+    payments = _tableIn_payments tableIn
+    paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
+
+getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
+getPaymentRange perPage payments currentPage =
+  take perPage
+    . drop ((currentPage - 1) * perPage)
     . reverse
     . L.sortOn _payment_date
     $ payments
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index be6b152..89be737 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -45,7 +45,7 @@ view result =
             ]
 
       button <- Component.button $ ButtonIn
-        { _buttonIn_class = R.constDyn ""
+        { _buttonIn_class = R.constDyn "validate"
         , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
         , _buttonIn_waiting = waiting
         }
@@ -57,7 +57,7 @@ view result =
 askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
 askSignIn email =
   fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email
+  where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email
         getResult response =
           case R._xhrResponse_responseText response of
             Just key ->
-- 
cgit v1.2.3


From ab17b6339d16970c3845ec4f153bfeed89eae728 Mon Sep 17 00:00:00 2001
From: Joris
Date: Fri, 5 Jan 2018 14:45:47 +0100
Subject: Add modal component

---
 client/src/Component.hs           |   1 +
 client/src/Component/Button.hs    |   4 +-
 client/src/Component/Modal.hs     |  38 +++++++++++
 client/src/View/Payment.hs        |  18 ++----
 client/src/View/Payment/Header.hs | 130 +++++++++++++++++++++++---------------
 5 files changed, 126 insertions(+), 65 deletions(-)
 create mode 100644 client/src/Component/Modal.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index 4c9541b..dea384e 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -2,3 +2,4 @@ module Component (module X) where
 
 import           Component.Button as X
 import           Component.Input  as X
+import           Component.Modal  as X
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 754b903..3ee9561 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -1,8 +1,8 @@
 module Component.Button
   ( ButtonIn(..)
-  , buttonInDefault
   , ButtonOut(..)
   , button
+  , buttonInDefault
   ) where
 
 import qualified Data.Map   as M
@@ -19,7 +19,7 @@ data ButtonIn t m = ButtonIn
   , _buttonIn_waiting :: Event t Bool
   }
 
-buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m
+buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m
 buttonInDefault = ButtonIn
   { _buttonIn_class = R.constDyn ""
   , _buttonIn_content = R.blank
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
new file mode 100644
index 0000000..bfb5e02
--- /dev/null
+++ b/client/src/Component/Modal.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Component.Modal
+  ( ModalIn(..)
+  , ModalOut(..)
+  , modal
+  ) where
+
+import qualified Data.Map   as M
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+data ModalIn t m = ModalIn
+  { _modalIn_show    :: Event t ()
+  , _modalIn_content :: m ()
+  }
+
+data ModalOut = ModalOut {}
+
+modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut
+modal modalIn = do
+  rec
+    showModal <- R.holdDyn False $ R.leftmost
+      [ True <$ _modalIn_show modalIn
+      , False <$ curtainClick
+      ]
+
+    let attr = flip fmap showModal (\s -> M.fromList $
+          [ ("style", if s then "display:block" else "display:none")
+          , ("class", "modal")
+          ])
+
+    curtainClick <- R.elDynAttr "div" attr $ do
+      (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank
+      R.divClass "content" $ _modalIn_content modalIn
+      return $ R.domEvent R.Click curtain
+
+  return $ ModalOut {}
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f4aaf5c..42da8fb 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -8,8 +8,7 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (MonadWidget)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Frequency (..), Init (..), Payment (..))
-import           Common.Util.Text    as T
+import           Common.Model        (Init (..))
 
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
@@ -31,13 +30,6 @@ widget paymentIn = do
   R.divClass "payment" $ do
     rec
       let init = _paymentIn_init paymentIn
-
-          filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual)
-
-          payments = fmap
-            (\s -> filter (filterPayment s) (_init_payments init))
-            (_headerOut_search header)
-
           paymentsPerPage = 7
 
       header <- Header.widget $ HeaderIn
@@ -47,14 +39,14 @@ widget paymentIn = do
       _ <- Table.widget $ TableIn
         { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pages
-        , _tableIn_payments = payments
+        , _tableIn_payments = _headerOut_searchPayments header
         , _tableIn_perPage = paymentsPerPage
         }
 
       pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> payments
+        { _pagesIn_total = length <$> _headerOut_searchPayments header
         , _pagesIn_perPage = paymentsPerPage
-        , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_search header
+        , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header
         }
 
-    return $ PaymentOut {}
+    pure $ PaymentOut {}
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index f64f11d..a694136 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -7,23 +7,26 @@ module View.Payment.Header
 import           Control.Monad          (forM_)
 import           Control.Monad.IO.Class (liftIO)
 import qualified Data.List              as L hiding (groupBy)
+import qualified Data.Map               as M
 import           Data.Maybe             (fromMaybe)
 import           Data.Text              (Text)
 import qualified Data.Text              as T
 import qualified Data.Time              as Time
 import           Prelude                hiding (init)
-import           Reflex.Dom             (Dynamic, MonadWidget)
+import           Reflex.Dom             (Dynamic, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
 import           Common.Model           (Currency, ExceedingPayer (..),
                                          Frequency (..), Income (..), Init (..),
-                                         Payment (..), User (..), UserId)
+                                         Payment (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
+import qualified Common.Util.Text       as T
 import qualified Common.View.Format     as Format
 
-import           Component              (ButtonIn (..), InputIn (..),
-                                         InputOut (..))
+import           Component              (ButtonIn (..), ButtonOut (..),
+                                         InputIn (..), InputOut (..),
+                                         ModalIn (..))
 import qualified Component              as Component
 import qualified Util.List              as L
 
@@ -32,23 +35,37 @@ data HeaderIn t = HeaderIn
   }
 
 data HeaderOut t = HeaderOut
-  { _headerOut_search :: Dynamic t Text
+  { _headerOut_searchName     :: Dynamic t Text
+  , _headerOut_searchPayments :: Dynamic t [Payment]
   }
 
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    payerAndAdd incomes payments users currency
-    search <- searchLine
-    infos payments users currency
+    payerAndAdd incomes punctualPayments users currency
+    (searchName, searchFrequency)  <- searchLine
+    let searchPayments = getSearchPayments searchName searchFrequency payments
+    infos searchPayments users currency
     return $ HeaderOut
-      { _headerOut_search = search
+      { _headerOut_searchName = searchName
+      , _headerOut_searchPayments = searchPayments
       }
-  where init = _headerIn_init headerIn
-        incomes = _init_incomes init
-        payments = filter ((==) Punctual . _payment_frequency) (_init_payments init)
-        users = _init_users init
-        currency = _init_currency init
+  where
+    init = _headerIn_init headerIn
+    incomes = _init_incomes init
+    payments = _init_payments init
+    punctualPayments = filter ((==) Punctual . _payment_frequency) payments
+    users = _init_users init
+    currency = _init_currency init
+
+getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
+getSearchPayments name frequency payments = do
+  n <- name
+  f <- frequency
+  pure $ flip filter payments (\p ->
+    (  T.search n (_payment_name p)
+    && (_payment_frequency p == f)
+    ))
 
 payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
 payerAndAdd incomes payments users currency = do
@@ -65,49 +82,62 @@ payerAndAdd incomes payments users currency = do
               R.text "+ "
               R.text . Format.price currency $ _exceedingPayer_amount p
         )
-    _ <- Component.button $ ButtonIn
+    addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
+      })
+    _ <- Component.modal $ ModalIn
+      { _modalIn_show    = addPayment
+      , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement"
       }
     return ()
 
-infos :: forall t m. MonadWidget t m => [Payment] -> [User] -> Currency -> m ()
+searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
+searchLine = do
+  R.divClass "searchLine" $ do
+    searchName <- _inputOut_value <$> (Component.input $ InputIn
+      { _inputIn_reset = R.never
+      , _inputIn_label = Msg.get Msg.Search_Name
+      })
+
+    let frequencies = M.fromList
+          [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+          , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+          ]
+
+    searchFrequency <- R._dropdown_value <$>
+      R.dropdown Punctual (R.constDyn frequencies) R.def
+
+    return (searchName, searchFrequency)
+
+infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m ()
 infos payments users currency =
   R.divClass "infos" $ do
-    R.elClass "span" "total" $ do
-      R.text . Msg.get $ Msg.Payment_Worth
-        (T.intercalate " "
-          [ (Format.number paymentCount)
-          , if paymentCount > 1
-              then Msg.get Msg.Payment_Many
-              else Msg.get Msg.Payment_One
-          ])
-        (Format.price currency total)
-    R.elClass "span" "partition" . R.text $
-      T.intercalate ", "
-        . map (\(userId, userTotal) ->
-            Msg.get $ Msg.Payment_By
-              (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
-              (Format.price currency userTotal)
-          )
-        $ totalByUser
 
-  where paymentCount = length payments
-        total = sum . map _payment_cost $ payments
-
-        totalByUser :: [(UserId, Int)]
-        totalByUser =
-          L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
-            . map (\(u, xs) -> (u, sum . map snd $ xs))
-            . L.groupBy fst
-            . map (\p -> (_payment_user p, _payment_cost p))
-            $ payments
+    R.elClass "span" "total" $ do
+      R.dynText $ do
+        ps <- payments
+        let paymentCount = length ps
+            total = sum . map _payment_cost $ ps
+        pure . Msg.get $ Msg.Payment_Worth
+          (T.intercalate " "
+            [ (Format.number paymentCount)
+            , if paymentCount > 1
+                then Msg.get Msg.Payment_Many
+                else Msg.get Msg.Payment_One
+            ])
+          (Format.price currency total)
 
-searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text)
-searchLine =
-  R.divClass "searchLine" $
-    _inputOut_value <$> (Component.input $ InputIn
-      { _inputIn_reset = R.never
-      , _inputIn_label = Msg.get Msg.Search_Name
-      })
+    R.elClass "span" "partition" . R.dynText $ do
+      ps <- payments
+      let totalByUser =
+            L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
+              . map (\(u, xs) -> (u, sum . map snd $ xs))
+              . L.groupBy fst
+              . map (\p -> (_payment_user p, _payment_cost p))
+              $ ps
+      pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
+        Msg.get $ Msg.Payment_By
+          (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
+          (Format.price currency userTotal)
-- 
cgit v1.2.3


From 33b85b7f12798f5762d940ed5c30f775cdd7b751 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Jan 2018 12:13:09 +0100
Subject: WIP

---
 client/src/Component.hs           |   2 +
 client/src/Component/Button.hs    |  41 ++++++++++-----
 client/src/Component/Form.hs      |  12 +++++
 client/src/Component/Input.hs     |  27 +++++++---
 client/src/Component/Modal.hs     |  24 +++++----
 client/src/Component/Select.hs    |  32 ++++++++++++
 client/src/Main.hs                |   4 +-
 client/src/Util/Ajax.hs           |  20 ++++++++
 client/src/Util/WaitFor.hs        |  18 +++++++
 client/src/View/App.hs            |   8 +--
 client/src/View/Header.hs         |  13 +++--
 client/src/View/Payment/Add.hs    | 104 ++++++++++++++++++++++++++++++++++++++
 client/src/View/Payment/Delete.hs |  51 +++++++++++++++++++
 client/src/View/Payment/Header.hs |  33 +++++++-----
 client/src/View/Payment/Pages.hs  |   2 +
 client/src/View/Payment/Table.hs  |  48 +++++++++++-------
 client/src/View/SignIn.hs         |  98 +++++++++++++++--------------------
 17 files changed, 410 insertions(+), 127 deletions(-)
 create mode 100644 client/src/Component/Form.hs
 create mode 100644 client/src/Component/Select.hs
 create mode 100644 client/src/Util/Ajax.hs
 create mode 100644 client/src/Util/WaitFor.hs
 create mode 100644 client/src/View/Payment/Add.hs
 create mode 100644 client/src/View/Payment/Delete.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index dea384e..7b87a75 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -1,5 +1,7 @@
 module Component (module X) where
 
 import           Component.Button as X
+import           Component.Form   as X
 import           Component.Input  as X
 import           Component.Modal  as X
+import           Component.Select as X
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 3ee9561..bf604f1 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -2,10 +2,11 @@ module Component.Button
   ( ButtonIn(..)
   , ButtonOut(..)
   , button
-  , buttonInDefault
+  , defaultButtonIn
   ) where
 
 import qualified Data.Map   as M
+import           Data.Maybe (catMaybes)
 import           Data.Text  (Text)
 import qualified Data.Text  as T
 import           Reflex.Dom (Dynamic, Event, MonadWidget)
@@ -14,22 +15,36 @@ import qualified Reflex.Dom as R
 import qualified Icon
 
 data ButtonIn t m = ButtonIn
-  { _buttonIn_class   :: Dynamic t Text
-  , _buttonIn_content :: m ()
-  , _buttonIn_waiting :: Event t Bool
+  { _buttonIn_class    :: Dynamic t Text
+  , _buttonIn_content  :: m ()
+  , _buttonIn_waiting  :: Event t Bool
+  , _buttonIn_tabIndex :: Maybe Int
+  , _buttonIn_submit   :: Bool
   }
 
-buttonInDefault :: forall t m. (MonadWidget t m) => ButtonIn t m
-buttonInDefault = ButtonIn
-  { _buttonIn_class = R.constDyn ""
-  , _buttonIn_content = R.blank
-  , _buttonIn_waiting = R.never
+defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m
+defaultButtonIn content = ButtonIn
+  { _buttonIn_class    = R.constDyn ""
+  , _buttonIn_content  = content
+  , _buttonIn_waiting  = R.never
+  , _buttonIn_tabIndex = Nothing
+  , _buttonIn_submit   = False
   }
 
+-- defaultButtonIn :: MonadWidget t m => ButtonIn t m
+-- defaultButtonIn = ButtonIn
+--   { _buttonIn_class    = R.constDyn ""
+--   , _buttonIn_content  = R.blank
+--   , _buttonIn_waiting  = R.never
+--   , _buttonIn_tabIndex = Nothing
+--   , _buttonIn_submit   = False
+--   }
+
 data ButtonOut t = ButtonOut
   { _buttonOut_clic :: Event t ()
   }
 
+
 button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
 button buttonIn = do
   dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn
@@ -37,9 +52,11 @@ button buttonIn = do
   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)]
+        return . M.fromList . catMaybes $
+          [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button")
+          , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn
+          , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ])
+          ]
 
   (e, _) <- R.elDynAttr' "button" attr $ do
     Icon.loading
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
new file mode 100644
index 0000000..0a89c6e
--- /dev/null
+++ b/client/src/Component/Form.hs
@@ -0,0 +1,12 @@
+module Component.Form
+  ( form
+  ) where
+
+import qualified Data.Map   as M
+import           Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+form :: forall t m a. (MonadWidget t m) => m a -> m a
+form content =
+  R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
+    content
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 24aac22..92f8ec9 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -2,12 +2,14 @@ module Component.Input
   ( InputIn(..)
   , InputOut(..)
   , input
+  , defaultInputIn
   ) where
 
 import qualified Data.Map         as M
 import           Data.Text        (Text)
 import qualified Data.Text        as T
-import           Reflex.Dom       (Dynamic, Event, MonadWidget, (&), (.~))
+import           Reflex.Dom       (Dynamic, Event, MonadWidget, Reflex, (&),
+                                   (.~))
 import qualified Reflex.Dom       as R
 
 import           Component.Button (ButtonIn (..), ButtonOut (..))
@@ -15,8 +17,16 @@ import qualified Component.Button as Button
 import qualified Icon
 
 data InputIn t a b = InputIn
-  { _inputIn_reset :: Event t a
-  , _inputIn_label :: Text
+  { _inputIn_reset        :: Event t a
+  , _inputIn_label        :: Text
+  , _inputIn_initialValue :: Text
+  }
+
+defaultInputIn :: (Reflex t) => InputIn t a b
+defaultInputIn = InputIn
+  { _inputIn_reset        = R.never
+  , _inputIn_label        = ""
+  , _inputIn_initialValue = ""
   }
 
 data InputOut t = InputOut
@@ -41,14 +51,15 @@ input inputIn =
       textInput <- R.textInput $ R.def
         & R.attributes .~ attributes
         & R.setValue .~ resetValue
+        & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
 
       R.el "label" $ R.text (_inputIn_label inputIn)
 
-      reset <- Button.button $ ButtonIn
-        { _buttonIn_class   = R.constDyn "reset"
-        , _buttonIn_content = Icon.cross
-        , _buttonIn_waiting = R.never
-        }
+      reset <- Button.button $
+        (Button.defaultButtonIn Icon.cross)
+          { _buttonIn_class   = R.constDyn "reset"
+          , _buttonIn_tabIndex = Just (-1)
+          }
 
     let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
 
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index bfb5e02..1d70c90 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -10,18 +10,22 @@ import qualified Data.Map   as M
 import           Reflex.Dom (Event, MonadWidget)
 import qualified Reflex.Dom as R
 
-data ModalIn t m = ModalIn
+data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
-  , _modalIn_content :: m ()
+  , _modalIn_hide    :: Event t ()
+  , _modalIn_content :: m a
   }
 
-data ModalOut = ModalOut {}
+data ModalOut a = ModalOut
+  { _modalOut_content :: a
+  }
 
-modal :: forall t m. MonadWidget t m => ModalIn t m -> m ModalOut
+modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a)
 modal modalIn = do
   rec
     showModal <- R.holdDyn False $ R.leftmost
       [ True <$ _modalIn_show modalIn
+      , False <$ _modalIn_hide modalIn
       , False <$ curtainClick
       ]
 
@@ -30,9 +34,11 @@ modal modalIn = do
           , ("class", "modal")
           ])
 
-    curtainClick <- R.elDynAttr "div" attr $ do
-      (curtain, _) <- R.elAttr' "div" (M.singleton "class" "curtain") $ R.blank
-      R.divClass "content" $ _modalIn_content modalIn
-      return $ R.domEvent R.Click curtain
+    (curtainClick, content) <- R.elDynAttr "div" attr $ do
+      (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
+      cont <- R.divClass "modalContent" $ _modalIn_content modalIn
+      return (R.domEvent R.Click curtain, cont)
 
-  return $ ModalOut {}
+  return $ ModalOut
+    { _modalOut_content = content
+    }
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
new file mode 100644
index 0000000..876548e
--- /dev/null
+++ b/client/src/Component/Select.hs
@@ -0,0 +1,32 @@
+module Component.Select
+  ( SelectIn(..)
+  , SelectOut(..)
+  , select
+  ) where
+
+import           Data.Map   (Map)
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, MonadWidget, Reflex)
+import qualified Reflex.Dom as R
+
+data (Reflex t) => SelectIn t a = SelectIn
+  { _selectIn_label        :: Text
+  , _selectIn_initialValue :: a
+  , _selectIn_values       :: Dynamic t (Map a Text)
+  }
+
+data SelectOut t a = SelectOut
+  { _selectOut_value :: Dynamic t a
+  }
+
+select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a)
+select selectIn =
+  R.divClass "selectInput" $ do
+    R.el "label" $ R.text (_selectIn_label selectIn)
+
+    value <- R._dropdown_value <$>
+      R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def
+
+    return SelectOut
+      { _selectOut_value = value
+      }
diff --git a/client/src/Main.hs b/client/src/Main.hs
index d55eefe..6c048c6 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -13,7 +13,7 @@ import           JSDOM.Types                          (HTMLElement (..), JSM)
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import           Common.Model                         (InitResult (InitEmpty))
+import           Common.Model                         (InitResult (InitError))
 import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
@@ -37,4 +37,4 @@ readInit = do
     _ ->
       return initParseError
 
-  where initParseError = InitEmpty (Left $ Msg.get Msg.SignIn_ParseError)
+  where initParseError = InitError $ Msg.get Msg.SignIn_ParseError
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
new file mode 100644
index 0000000..1e8e4c7
--- /dev/null
+++ b/client/src/Util/Ajax.hs
@@ -0,0 +1,20 @@
+module Util.Ajax
+  ( post
+  ) where
+
+import           Data.Aeson (ToJSON)
+import           Data.Text  (Text)
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
+post url input =
+  fmap getResult <$> R.performRequestAsync xhrRequest
+  where xhrRequest = R.postJson url <$> input
+        getResult response =
+          case R._xhrResponse_responseText response of
+            Just responseText ->
+              if R._xhrResponse_status response == 200
+                then Right responseText
+                else Left responseText
+            _ -> Left "NoKey"
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
new file mode 100644
index 0000000..0175c95
--- /dev/null
+++ b/client/src/Util/WaitFor.hs
@@ -0,0 +1,18 @@
+module Util.WaitFor
+  ( waitFor
+  ) where
+
+import           Data.Time  (NominalDiffTime)
+import           Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+waitFor
+  :: forall t m a b. MonadWidget t m
+  => (Event t a -> m (Event t b))
+  -> Event t ()
+  -> Dynamic t a
+  -> m (Event t b, Event t Bool)
+waitFor op start input = do
+  result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime)
+  let waiting = R.leftmost [ const True <$> start , const False <$> result ]
+  return (result, waiting)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 64ca303..9aa6c57 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -29,10 +29,12 @@ widget initResult =
               { _paymentIn_init = initSuccess
               }
             return ()
-          InitEmpty result ->
-            SignIn.view result
+          InitEmpty ->
+            SignIn.view SignIn.EmptyMessage
+          InitError error ->
+            SignIn.view (SignIn.ErrorMessage error)
 
-        signOutContent = SignIn.view (Right . Just $ Msg.get Msg.SignIn_DisconnectSuccess)
+        signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
 
     _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
 
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 4c74383..8f1fb78 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -13,9 +13,8 @@ import qualified Reflex.Dom       as R
 import           Common.Model     (Init (..), InitResult (..), User (..))
 import qualified Common.Model     as CM
 import qualified Common.Msg       as Msg
-
+import qualified Component        as Component
 import           Component.Button (ButtonIn (..))
-import qualified Component.Button as Component
 import qualified Icon
 
 data HeaderIn = HeaderIn
@@ -60,11 +59,11 @@ nameSignOut initResult = case initResult of
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
   rec
-    signOut <- Component.button $ ButtonIn
-      { Component._buttonIn_class = R.constDyn "signOut item"
-      , Component._buttonIn_content = Icon.signOut
-      , Component._buttonIn_waiting = waiting
-      }
+    signOut <- Component.button $
+      (Component.defaultButtonIn Icon.signOut)
+        { _buttonIn_class = R.constDyn "signOut item"
+        , _buttonIn_waiting = waiting
+        }
     let signOutClic = Component._buttonOut_clic signOut
         waiting = R.leftmost
           [ fmap (const True) signOutClic
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
new file mode 100644
index 0000000..2eaec0f
--- /dev/null
+++ b/client/src/View/Payment/Add.hs
@@ -0,0 +1,104 @@
+module View.Payment.Add
+  ( view
+  , AddIn(..)
+  , AddOut(..)
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Map               as M
+import qualified Data.Maybe             as Maybe
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Time
+import           Reflex.Dom             (Event, MonadWidget)
+import qualified Reflex.Dom             as R
+import qualified Text.Read              as T
+
+import           Common.Model           (Category (..), CreatePayment (..),
+                                         Frequency (..))
+import qualified Common.Msg             as Msg
+import qualified Common.Util.Time       as Time
+import qualified Common.View.Format     as Format
+import           Component              (ButtonIn (..), InputIn (..),
+                                         InputOut (..), SelectIn (..),
+                                         SelectOut (..))
+import qualified Component              as Component
+import qualified Util.Ajax              as Ajax
+import qualified Util.WaitFor           as Util
+
+data AddIn = AddIn
+  { _addIn_categories :: [Category]
+  }
+
+data AddOut t = AddOut
+  { _addOut_cancel :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t)
+view addIn = do
+  R.divClass "add" $ do
+    R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
+
+    R.divClass "addContent" $ do
+      name <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+
+      cost <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+
+      currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+
+      date <- _inputOut_value <$> (Component.input $
+        Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Payment_Cost
+          , _inputIn_initialValue = Format.shortDay currentDay
+          })
+
+      frequency <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Frequency
+        , _selectIn_initialValue = Punctual
+        , _selectIn_values = R.constDyn frequencies
+        })
+
+      category <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Category
+        , _selectIn_initialValue = 0
+        , _selectIn_values = R.constDyn categories
+        })
+
+      let payment = CreatePayment
+            <$> name
+            <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
+            <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
+            <*> category
+            <*> frequency
+
+      cancel <- R.divClass "buttons" $ do
+        rec
+          validate <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { _buttonIn_class = R.constDyn "confirm"
+              , _buttonIn_waiting = waiting
+              , _buttonIn_submit = True
+              })
+
+          (_, waiting) <- Util.waitFor
+            (Ajax.post "/payment")
+            validate
+            payment
+
+        Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
+      return AddOut
+        { _addOut_cancel = cancel
+        }
+
+  where
+    frequencies = M.fromList
+      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+      ]
+
+    categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
+      (_category_id c, _category_name c)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
new file mode 100644
index 0000000..a1be16d
--- /dev/null
+++ b/client/src/View/Payment/Delete.hs
@@ -0,0 +1,51 @@
+module View.Payment.Delete
+  ( view
+  , DeleteIn(..)
+  , DeleteOut(..)
+  ) where
+
+import           Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import           Component  (ButtonIn (..), ButtonOut (..))
+import qualified Component  as Component
+-- import qualified Util.Ajax              as Ajax
+-- import qualified Util.WaitFor           as Util
+
+data DeleteIn = DeleteIn
+  {}
+
+data DeleteOut t = DeleteOut
+  { _deleteOut_cancel :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
+view _ =
+  R.divClass "delete" $ do
+    R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
+
+    R.divClass "deleteContent" $ do
+
+      cancel <- R.divClass "buttons" $ do
+        rec
+          _ <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { _buttonIn_class = R.constDyn "confirm"
+              , _buttonIn_submit = True
+              })
+
+          -- (_, waiting) <- Util.waitFor
+          --   (Ajax.post "/payment")
+          --   validate
+          --   payment
+
+        cancel <- Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
+        return cancel
+
+      return DeleteOut
+        { _deleteOut_cancel = cancel
+        }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index a694136..d01dec6 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -16,9 +16,10 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, ExceedingPayer (..),
-                                         Frequency (..), Income (..), Init (..),
-                                         Payment (..), User (..))
+import           Common.Model           (Category, Currency,
+                                         ExceedingPayer (..), Frequency (..),
+                                         Income (..), Init (..), Payment (..),
+                                         User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Text       as T
@@ -26,9 +27,11 @@ import qualified Common.View.Format     as Format
 
 import           Component              (ButtonIn (..), ButtonOut (..),
                                          InputIn (..), InputOut (..),
-                                         ModalIn (..))
+                                         ModalIn (..), ModalOut (..))
 import qualified Component              as Component
 import qualified Util.List              as L
+import           View.Payment.Add       (AddIn (..), AddOut (..))
+import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
   { _headerIn_init :: Init
@@ -42,7 +45,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    payerAndAdd incomes punctualPayments users currency
+    payerAndAdd incomes punctualPayments users categories currency
     (searchName, searchFrequency)  <- searchLine
     let searchPayments = getSearchPayments searchName searchFrequency payments
     infos searchPayments users currency
@@ -56,6 +59,7 @@ widget headerIn =
     payments = _init_payments init
     punctualPayments = filter ((==) Punctual . _payment_frequency) payments
     users = _init_users init
+    categories = _init_categories init
     currency = _init_currency init
 
 getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
@@ -63,12 +67,12 @@ getSearchPayments name frequency payments = do
   n <- name
   f <- frequency
   pure $ flip filter payments (\p ->
-    (  T.search n (_payment_name p)
+    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
     && (_payment_frequency p == f)
     ))
 
-payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> Currency -> m ()
-payerAndAdd incomes payments users currency = do
+payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
+payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
     R.divClass "exceedingPayers" $
@@ -86,11 +90,15 @@ payerAndAdd incomes payments users currency = do
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
+      , _buttonIn_tabIndex = Nothing
+      , _buttonIn_submit = False
       })
-    _ <- Component.modal $ ModalIn
-      { _modalIn_show    = addPayment
-      , _modalIn_content = R.el "h1" $ R.text "Ajouter un paiement"
-      }
+    rec
+      modalOut <- Component.modal $ ModalIn
+        { _modalIn_show    = addPayment
+        , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
+        }
     return ()
 
 searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
@@ -99,6 +107,7 @@ searchLine = do
     searchName <- _inputOut_value <$> (Component.input $ InputIn
       { _inputIn_reset = R.never
       , _inputIn_label = Msg.get Msg.Search_Name
+      , _inputIn_initialValue = ""
       })
 
     let frequencies = M.fromList
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 55ceb9f..d14b640 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -82,5 +82,7 @@ pageButton currentPage page content = do
         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/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index a49be5c..23d7225 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,23 +4,28 @@ 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         (Dynamic, MonadWidget)
-import qualified Reflex.Dom         as R
-
-import           Common.Model       (Category (..), Init (..), Payment (..),
-                                     PaymentCategory (..), User (..))
-import qualified Common.Model       as CM
-import qualified Common.Msg         as Msg
-import qualified Common.Util.Text   as T
-import qualified Common.View.Format as Format
+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           Common.Model        (Category (..), Init (..), Payment (..),
+                                      PaymentCategory (..), User (..))
+import qualified Common.Model        as CM
+import qualified Common.Msg          as Msg
+import qualified Common.Util.Text    as T
+import qualified Common.View.Format  as Format
+import           Component           (ButtonIn (..), ButtonOut (..),
+                                      ModalIn (..), ModalOut (..))
+import qualified Component           as Component
+import           View.Payment.Delete (DeleteIn (..), DeleteOut (..))
+import qualified View.Payment.Delete as Delete
 
 import qualified Icon
-import qualified Util.Dom           as Dom
+import qualified Util.Dom            as Dom
 
 data TableIn t = TableIn
   { _tableIn_init        :: Init
@@ -105,8 +110,17 @@ paymentRow init payment =
           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
+    deletePayment <- R.elDynAttr "div" modifyAttrs $
+      _buttonOut_clic <$> (Component.button $
+        (Component.defaultButtonIn Icon.delete)
+          { _buttonIn_class = R.constDyn "deletePayment" })
+    rec
+      modalOut <- Component.modal $ ModalIn
+        { _modalIn_show    = deletePayment
+        , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_content = Delete.view (DeleteIn {})
+        }
+    return ()
 
 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 89be737..912aea2 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,11 +1,10 @@
 module View.SignIn
-  ( view
+  ( SignInMessage (..)
+  , 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   (Event, MonadWidget)
 import qualified Reflex.Dom   as R
@@ -16,62 +15,47 @@ import qualified Common.Msg   as Msg
 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 =
-  R.divClass "signIn" $ do
-    rec
-      input <- Component.input $ InputIn
-        { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-        }
-
-      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
-
-      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
-        [ fmap (const True) userWantsEmailValidation
-        , fmap (const False) signInResult
-        ]
-
-      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
-
-      let validatedEmail = R.tagPromptlyDyn
-            (_inputOut_value input)
-            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
-
-      let waiting = R.leftmost
-            [ fmap (const True) validatedEmail
-            , fmap (const False) signInResult
-            ]
-
-      button <- Component.button $ ButtonIn
-        { _buttonIn_class = R.constDyn "validate"
-        , _buttonIn_content = R.text (Msg.get Msg.SignIn_Button)
-        , _buttonIn_waiting = waiting
-        }
-
-      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
-
-    showSignInResult result signInResult
-
-askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
-askSignIn email =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/askSignIn" . SignIn) email
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just key ->
-              if R._xhrResponse_status response == 200 then Right key else Left key
-            _ -> Left "NoKey"
-
-showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
-showSignInResult result signInResult = do
-  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+import qualified Util.Ajax    as Ajax
+import qualified Util.WaitFor as Util
+
+data SignInMessage =
+  SuccessMessage Text
+  | ErrorMessage Text
+  | EmptyMessage
+
+view :: forall t m. MonadWidget t m => SignInMessage -> m ()
+view signInMessage =
+  R.divClass "signIn" $
+    Component.form $ do
+      rec
+        input <- Component.input $ InputIn
+          { _inputIn_reset = R.ffilter Either.isRight signInResult
+          , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
+          , _inputIn_initialValue = ""
+          }
+
+        button <- Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
+            { _buttonIn_class = R.constDyn "validate"
+            , _buttonIn_waiting = waiting
+            , _buttonIn_submit = True
+            }
+
+        (signInResult, waiting) <- Util.waitFor
+          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+          (_buttonOut_clic button)
+          (_inputOut_value input)
+
+      showSignInResult signInMessage signInResult
+
+showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m ()
+showSignInResult signInMessage signInResult = do
+  _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult
   R.blank
 
-  where showInitResult (Left error)           = showError error
-        showInitResult (Right (Just success)) = showSuccess success
-        showInitResult (Right Nothing)        = R.blank
+  where showInitResult (SuccessMessage success) = showSuccess success
+        showInitResult (ErrorMessage error)     = showError error
+        showInitResult EmptyMessage             = R.blank
 
         showResult (Left error)    = showError error
         showResult (Right success) = showSuccess success
-- 
cgit v1.2.3


From df83b634006c699cfa1e921bf74ce951a906a62f Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 24 Jun 2018 22:02:00 +0200
Subject: Use date input type

---
 client/src/Component/Button.hs    | 10 ----------
 client/src/Component/Input.hs     | 38 +++++++++++++++++++++++++-------------
 client/src/View/Payment/Add.hs    |  8 +++++---
 client/src/View/Payment/Header.hs |  6 ++----
 client/src/View/SignIn.hs         |  2 ++
 5 files changed, 34 insertions(+), 30 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index bf604f1..46c0afa 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -31,20 +31,10 @@ defaultButtonIn content = ButtonIn
   , _buttonIn_submit   = False
   }
 
--- defaultButtonIn :: MonadWidget t m => ButtonIn t m
--- defaultButtonIn = ButtonIn
---   { _buttonIn_class    = R.constDyn ""
---   , _buttonIn_content  = R.blank
---   , _buttonIn_waiting  = R.never
---   , _buttonIn_tabIndex = Nothing
---   , _buttonIn_submit   = False
---   }
-
 data ButtonOut t = ButtonOut
   { _buttonOut_clic :: Event t ()
   }
 
-
 button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
 button buttonIn = do
   dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 92f8ec9..c1eb4e8 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -17,16 +17,20 @@ import qualified Component.Button as Button
 import qualified Icon
 
 data InputIn t a b = InputIn
-  { _inputIn_reset        :: Event t a
-  , _inputIn_label        :: Text
-  , _inputIn_initialValue :: Text
+  { _inputIn_reset          :: Event t a
+  , _inputIn_hasResetButton :: Bool
+  , _inputIn_label          :: Text
+  , _inputIn_initialValue   :: Text
+  , _inputIn_inputType      :: Text
   }
 
 defaultInputIn :: (Reflex t) => InputIn t a b
 defaultInputIn = InputIn
-  { _inputIn_reset        = R.never
-  , _inputIn_label        = ""
-  , _inputIn_initialValue = ""
+  { _inputIn_reset          = R.never
+  , _inputIn_hasResetButton = True
+  , _inputIn_label          = ""
+  , _inputIn_initialValue   = ""
+  , _inputIn_inputType      = "text"
   }
 
 data InputOut t = InputOut
@@ -40,11 +44,13 @@ input inputIn =
     rec
       let resetValue = R.leftmost
             [ fmap (const "") (_inputIn_reset inputIn)
-            , fmap (const "") (_buttonOut_clic reset)
+            , fmap (const "") resetClic
             ]
 
           attributes = R.ffor value (\v ->
-            if T.null v then M.empty else M.singleton "class" "filled")
+            if T.null v && _inputIn_inputType inputIn /= "date"
+              then M.empty
+              else M.singleton "class" "filled")
 
           value =  R._textInput_value textInput
 
@@ -52,14 +58,20 @@ input inputIn =
         & R.attributes .~ attributes
         & R.setValue .~ resetValue
         & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
+        & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
 
       R.el "label" $ R.text (_inputIn_label inputIn)
 
-      reset <- Button.button $
-        (Button.defaultButtonIn Icon.cross)
-          { _buttonIn_class   = R.constDyn "reset"
-          , _buttonIn_tabIndex = Just (-1)
-          }
+      resetClic <-
+        if _inputIn_hasResetButton inputIn
+          then
+            _buttonOut_clic <$> (Button.button $
+              (Button.defaultButtonIn Icon.cross)
+                { _buttonIn_class   = R.constDyn "reset"
+                , _buttonIn_tabIndex = Just (-1)
+                })
+          else
+            return R.never
 
     let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
 
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 2eaec0f..5ff09dd 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -8,6 +8,7 @@ import           Control.Monad.IO.Class (liftIO)
 import qualified Data.Map               as M
 import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
+import qualified Data.Time.Calendar     as Calendar
 import qualified Data.Time.Clock        as Time
 import           Reflex.Dom             (Event, MonadWidget)
 import qualified Reflex.Dom             as R
@@ -17,7 +18,6 @@ import           Common.Model           (Category (..), CreatePayment (..),
                                          Frequency (..))
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as Time
-import qualified Common.View.Format     as Format
 import           Component              (ButtonIn (..), InputIn (..),
                                          InputOut (..), SelectIn (..),
                                          SelectOut (..))
@@ -49,8 +49,10 @@ view addIn = do
 
       date <- _inputOut_value <$> (Component.input $
         Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Payment_Cost
-          , _inputIn_initialValue = Format.shortDay currentDay
+          { _inputIn_label = Msg.get Msg.Payment_Date
+          , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
+          , _inputIn_inputType = "date"
+          , _inputIn_hasResetButton = False
           })
 
       frequency <- _selectOut_value <$> (Component.select $ SelectIn
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index d01dec6..fd46c25 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -104,10 +104,8 @@ payerAndAdd incomes payments users categories currency = do
 searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
 searchLine = do
   R.divClass "searchLine" $ do
-    searchName <- _inputOut_value <$> (Component.input $ InputIn
-      { _inputIn_reset = R.never
-      , _inputIn_label = Msg.get Msg.Search_Name
-      , _inputIn_initialValue = ""
+    searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn
+      { _inputIn_label = Msg.get Msg.Search_Name
       })
 
     let frequencies = M.fromList
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 912aea2..21d0fcc 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -30,8 +30,10 @@ view signInMessage =
       rec
         input <- Component.input $ InputIn
           { _inputIn_reset = R.ffilter Either.isRight signInResult
+          , _inputIn_hasResetButton = True
           , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
           , _inputIn_initialValue = ""
+          , _inputIn_inputType = "text"
           }
 
         button <- Component.button $
-- 
cgit v1.2.3


From 40b4994797a797b1fa86cafda789a5c488730c6d Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 28 Oct 2018 17:57:58 +0100
Subject: Delete payment

---
 client/src/Component/Form.hs      |  2 +-
 client/src/Component/Modal.hs     | 33 ++++++++++++-------
 client/src/Component/Select.hs    |  2 +-
 client/src/Util/Ajax.hs           | 67 +++++++++++++++++++++++++++++----------
 client/src/Util/Dom.hs            | 36 ++++++++++++++++++---
 client/src/View/Payment/Add.hs    |  6 ++--
 client/src/View/Payment/Delete.hs | 40 +++++++++++++----------
 client/src/View/Payment/Header.hs |  4 +--
 client/src/View/Payment/Table.hs  |  2 +-
 client/src/View/SignIn.hs         |  6 ++--
 10 files changed, 139 insertions(+), 59 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
index 0a89c6e..6ea02fa 100644
--- a/client/src/Component/Form.hs
+++ b/client/src/Component/Form.hs
@@ -6,7 +6,7 @@ import qualified Data.Map   as M
 import           Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-form :: forall t m a. (MonadWidget t m) => m a -> m a
+form :: forall t m a. MonadWidget t m => m a -> m a
 form content =
   R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
     content
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 1d70c90..72091c9 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,14 +1,19 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module Component.Modal
   ( ModalIn(..)
   , ModalOut(..)
   , modal
   ) where
 
-import qualified Data.Map   as M
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
+import           Control.Monad    (void)
+import qualified Data.Map         as M
+import qualified Data.Map.Lazy    as LM
+import           Data.Text        (Text)
+import qualified GHCJS.DOM.Node   as Node
+import           Reflex.Dom       (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom       as R
+import qualified Reflex.Dom.Class as R
+
+import qualified Util.Dom         as Dom
 
 data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
@@ -29,16 +34,22 @@ modal modalIn = do
       , False <$ curtainClick
       ]
 
-    let attr = flip fmap showModal (\s -> M.fromList $
-          [ ("style", if s then "display:block" else "display:none")
-          , ("class", "modal")
-          ])
-
-    (curtainClick, content) <- R.elDynAttr "div" attr $ do
+    (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do
       (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
       cont <- R.divClass "modalContent" $ _modalIn_content modalIn
       return (R.domEvent R.Click curtain, cont)
 
+  body <- Dom.getBody
+  let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn)
+  R.performEvent_ $ void `fmap` moveBackdrop
+
   return $ ModalOut
     { _modalOut_content = content
     }
+
+getAttributes :: Bool -> LM.Map Text Text
+getAttributes show =
+  M.fromList $
+    [ ("style", if show then "display:block" else "display:none")
+    , ("class", "modal")
+    ]
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 876548e..17a4958 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -19,7 +19,7 @@ data SelectOut t a = SelectOut
   { _selectOut_value :: Dynamic t a
   }
 
-select :: forall t m a. (Ord a) => MonadWidget t m => SelectIn t a -> m (SelectOut t a)
+select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a)
 select selectIn =
   R.divClass "selectInput" $ do
     R.el "label" $ R.text (_selectIn_label selectIn)
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 1e8e4c7..14675df 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,55 @@
 module Util.Ajax
-  ( post
+  ( postJson
+  , delete
   ) where
 
-import           Data.Aeson (ToJSON)
-import           Data.Text  (Text)
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
+import           Data.Aeson    (ToJSON)
+import           Data.Default  (def)
+import qualified Data.Map.Lazy as LM
+import           Data.Text     (Text)
+import           Reflex.Dom    (Dynamic, Event, IsXhrPayload, MonadWidget,
+                                XhrRequest, XhrRequestConfig (..), XhrResponse,
+                                XhrResponseHeaders (..))
+import qualified Reflex.Dom    as R
 
-post :: forall t m a. (MonadWidget t m, ToJSON a) => Text -> Event t a -> m (Event t (Either Text Text))
-post url input =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = R.postJson url <$> input
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just responseText ->
-              if R._xhrResponse_status response == 200
-                then Right responseText
-                else Left responseText
-            _ -> Left "NoKey"
+postJson
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text Text))
+postJson url input =
+  fmap getResult <$>
+    R.performRequestAsync (R.postJson url <$> input)
+
+delete
+  :: forall t m. MonadWidget t m
+  => Dynamic t Text
+  -> Event t ()
+  -> m (Event t (Either Text Text))
+delete url fire =
+  fmap getResult <$>
+    R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+
+getResult :: XhrResponse -> Either Text Text
+getResult response =
+  case R._xhrResponse_responseText response of
+    Just responseText ->
+      if R._xhrResponse_status response == 200
+        then Right responseText
+        else Left responseText
+    _ -> Left "NoKey"
+
+request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
+request method url sendData =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = sendData
+      }
+  in
+    R.xhrRequest method url config
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
index f3e9c88..55b8521 100644
--- a/client/src/Util/Dom.hs
+++ b/client/src/Util/Dom.hs
@@ -1,12 +1,31 @@
 module Util.Dom
-  ( divVisibleIf
+  ( divIfDyn
+  , divIfEvent
+  , divVisibleIf
   , divClassVisibleIf
+  , getBody
   ) where
 
-import qualified Data.Map   as M
-import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Map                 as M
+import           Data.Text                (Text)
+import qualified GHCJS.DOM                as Dom
+import qualified GHCJS.DOM.Document       as Document
+import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
+import           GHCJS.DOM.Types          (Element)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
+divIfDyn cond = divIfEvent (R.updated cond)
+
+divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+divIfEvent cond empty content =
+  R.widgetHold empty (flip fmap cond (\show ->
+    if show
+      then
+        content
+      else
+        empty))
 
 divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
 divVisibleIf cond content = divClassVisibleIf cond "" content
@@ -17,3 +36,10 @@ divClassVisibleIf cond className content =
     "div"
     (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
     content
+
+getBody :: forall t m. MonadWidget t m => m Element
+getBody = do
+  document <- Dom.currentDocumentUnchecked
+  nodelist <- Document.getElementsByTagName document ("body" :: String)
+  Just body <- nodelist `HTMLCollection.item` 0
+  return body
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 5ff09dd..8b1b56e 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -23,7 +23,7 @@ import           Component              (ButtonIn (..), InputIn (..),
                                          SelectOut (..))
 import qualified Component              as Component
 import qualified Util.Ajax              as Ajax
-import qualified Util.WaitFor           as Util
+import qualified Util.WaitFor           as WaitFor
 
 data AddIn = AddIn
   { _addIn_categories :: [Category]
@@ -83,8 +83,8 @@ view addIn = do
               , _buttonIn_submit = True
               })
 
-          (_, waiting) <- Util.waitFor
-            (Ajax.post "/payment")
+          (_, waiting) <- WaitFor.waitFor
+            (Ajax.postJson "/payment")
             validate
             payment
 
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index a1be16d..03cf267 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,24 +4,27 @@ module View.Payment.Delete
   , DeleteOut(..)
   ) where
 
-import           Reflex.Dom (Event, MonadWidget)
-import qualified Reflex.Dom as R
-
-import qualified Common.Msg as Msg
-import           Component  (ButtonIn (..), ButtonOut (..))
-import qualified Component  as Component
--- import qualified Util.Ajax              as Ajax
--- import qualified Util.WaitFor           as Util
-
-data DeleteIn = DeleteIn
-  {}
+import qualified Data.Text            as T
+import           Reflex.Dom           (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom           as R
+
+import           Common.Model.Payment (PaymentId)
+import qualified Common.Msg           as Msg
+import           Component            (ButtonIn (..), ButtonOut (..))
+import qualified Component            as Component
+import qualified Util.Ajax            as Ajax
+-- import qualified Util.WaitFor           as WaitFor
+
+data DeleteIn t = DeleteIn
+  { _deleteIn_id :: Dynamic t PaymentId
+  }
 
 data DeleteOut t = DeleteOut
   { _deleteOut_cancel :: Event t ()
   }
 
-view :: forall t m. MonadWidget t m => DeleteIn -> m (DeleteOut t)
-view _ =
+view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
+view deleteIn =
   R.divClass "delete" $ do
     R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
 
@@ -29,14 +32,19 @@ view _ =
 
       cancel <- R.divClass "buttons" $ do
         rec
-          _ <- Component._buttonOut_clic <$> (Component.button $
+          confirm <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
               { _buttonIn_class = R.constDyn "confirm"
               , _buttonIn_submit = True
               })
 
-          -- (_, waiting) <- Util.waitFor
-          --   (Ajax.post "/payment")
+          let url = flip fmap (_deleteIn_id deleteIn) (\id ->
+                  T.concat ["/payment/", T.pack . show $ id]
+                )
+          Ajax.delete url confirm
+
+          -- (_, waiting) <- WaitFor.waitFor
+          --   (Ajax.delete "/payment")
           --   validate
           --   payment
 
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index fd46c25..be7f6d5 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -86,7 +86,7 @@ payerAndAdd incomes payments users categories currency = do
               R.text "+ "
               R.text . Format.price currency $ _exceedingPayer_amount p
         )
-    addPayment <- _buttonOut_clic <$> (Component.button $ ButtonIn
+    addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
       , _buttonIn_waiting = R.never
@@ -95,7 +95,7 @@ payerAndAdd incomes payments users categories currency = do
       })
     rec
       modalOut <- Component.modal $ ModalIn
-        { _modalIn_show    = addPayment
+        { _modalIn_show    = addPaymentClic
         , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
         , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 23d7225..13cedda 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -118,7 +118,7 @@ paymentRow init payment =
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
         , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
-        , _modalIn_content = Delete.view (DeleteIn {})
+        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
         }
     return ()
 
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 21d0fcc..24e5be0 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -16,7 +16,7 @@ import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
                                InputOut (..))
 import qualified Component    as Component
 import qualified Util.Ajax    as Ajax
-import qualified Util.WaitFor as Util
+import qualified Util.WaitFor as WaitFor
 
 data SignInMessage =
   SuccessMessage Text
@@ -43,8 +43,8 @@ view signInMessage =
             , _buttonIn_submit = True
             }
 
-        (signInResult, waiting) <- Util.waitFor
-          (\email -> Ajax.post "/askSignIn" (SignIn <$> email))
+        (signInResult, waiting) <- WaitFor.waitFor
+          (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email))
           (_buttonOut_clic button)
           (_inputOut_value input)
 
-- 
cgit v1.2.3


From 50fb8fa48d1c4881da20b4ecf6d68a772301e713 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 18:04:58 +0100
Subject: Update table when adding or removing a payment

---
 client/src/Component/Input.hs     | 20 +++++-----
 client/src/Component/Modal.hs     | 66 +++++++++++++++++++++-----------
 client/src/Component/Select.hs    | 10 ++++-
 client/src/Icon.hs                |  2 +-
 client/src/Main.hs                |  5 ++-
 client/src/Util/Ajax.hs           | 40 ++++++++++++--------
 client/src/Util/Either.hs         |  7 ++++
 client/src/View/Payment.hs        | 61 ++++++++++++++++++++++++++----
 client/src/View/Payment/Add.hs    | 39 ++++++++++++-------
 client/src/View/Payment/Delete.hs | 13 +++++--
 client/src/View/Payment/Header.hs | 79 +++++++++++++++++++++++----------------
 client/src/View/Payment/Pages.hs  |  2 +-
 client/src/View/Payment/Table.hs  | 29 ++++++++------
 client/src/View/SignIn.hs         | 10 ++---
 14 files changed, 255 insertions(+), 128 deletions(-)
 create mode 100644 client/src/Util/Either.hs

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index c1eb4e8..57018a6 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -16,18 +16,16 @@ import           Component.Button (ButtonIn (..), ButtonOut (..))
 import qualified Component.Button as Button
 import qualified Icon
 
-data InputIn t a b = InputIn
-  { _inputIn_reset          :: Event t a
-  , _inputIn_hasResetButton :: Bool
+data InputIn = InputIn
+  { _inputIn_hasResetButton :: Bool
   , _inputIn_label          :: Text
   , _inputIn_initialValue   :: Text
   , _inputIn_inputType      :: Text
   }
 
-defaultInputIn :: (Reflex t) => InputIn t a b
+defaultInputIn :: InputIn
 defaultInputIn = InputIn
-  { _inputIn_reset          = R.never
-  , _inputIn_hasResetButton = True
+  { _inputIn_hasResetButton = True
   , _inputIn_label          = ""
   , _inputIn_initialValue   = ""
   , _inputIn_inputType      = "text"
@@ -38,12 +36,16 @@ data InputOut t = InputOut
   , _inputOut_enter :: Event t ()
   }
 
-input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t)
-input inputIn =
+input
+  :: forall t m a b. MonadWidget t m
+  => InputIn
+  -> Event t a -- reset
+  -> m (InputOut t)
+input inputIn reset =
   R.divClass "textInput" $ do
     rec
       let resetValue = R.leftmost
-            [ fmap (const "") (_inputIn_reset inputIn)
+            [ fmap (const "") reset
             , fmap (const "") resetClic
             ]
 
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 72091c9..b86fee0 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -4,16 +4,18 @@ module Component.Modal
   , modal
   ) where
 
-import           Control.Monad    (void)
-import qualified Data.Map         as M
-import qualified Data.Map.Lazy    as LM
-import           Data.Text        (Text)
-import qualified GHCJS.DOM.Node   as Node
-import           Reflex.Dom       (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom       as R
-import qualified Reflex.Dom.Class as R
+import           Control.Monad     (void)
+import qualified Data.Map          as M
+import qualified Data.Map.Lazy     as LM
+import           Data.Text         (Text)
+import qualified GHCJS.DOM.Element as Element
+import qualified GHCJS.DOM.Node    as Node
+import           JSDOM.Types       (JSString)
+import           Reflex.Dom        (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom        as R
+import qualified Reflex.Dom.Class  as R
 
-import qualified Util.Dom         as Dom
+import qualified Util.Dom          as Dom
 
 data ModalIn t m a = ModalIn
   { _modalIn_show    :: Event t ()
@@ -28,20 +30,21 @@ data ModalOut a = ModalOut
 modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a)
 modal modalIn = do
   rec
-    showModal <- R.holdDyn False $ R.leftmost
-      [ True <$ _modalIn_show modalIn
-      , False <$ _modalIn_hide modalIn
-      , False <$ curtainClick
-      ]
+    let showEvent = R.leftmost
+          [ True <$ _modalIn_show modalIn
+          , False <$ _modalIn_hide modalIn
+          , False <$ curtainClick
+          ]
 
-    (elem, (curtainClick, content)) <- R.buildElement "div" (getAttributes <$> showModal) $ do
-      (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
-      cont <- R.divClass "modalContent" $ _modalIn_content modalIn
-      return (R.domEvent R.Click curtain, cont)
+    showModal <- R.holdDyn False showEvent
 
-  body <- Dom.getBody
-  let moveBackdrop = (const $ (Node.appendChild body elem)) `fmap` (_modalIn_show modalIn)
-  R.performEvent_ $ void `fmap` moveBackdrop
+    (elem, (curtainClick, content)) <-
+      R.buildElement "div" (getAttributes <$> showModal) $ do
+        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
+        cont <- R.divClass "modalContent" $ _modalIn_content modalIn
+        return (R.domEvent R.Click curtain, cont)
+
+  performShowEffects showEvent elem
 
   return $ ModalOut
     { _modalOut_content = content
@@ -53,3 +56,24 @@ getAttributes show =
     [ ("style", if show then "display:block" else "display:none")
     , ("class", "modal")
     ]
+
+performShowEffects
+  :: forall t m a. MonadWidget t m
+  => Event t Bool
+  -> Element.Element
+  -> m ()
+performShowEffects showEvent elem = do
+  body <- Dom.getBody
+
+  let showEffects =
+        flip fmap showEvent (\show -> do
+          if show
+            then
+              do
+                Node.appendChild body elem
+                Element.setClassName body ("modal" :: JSString)
+            else
+              Element.setClassName body ("" :: JSString)
+        )
+
+  R.performEvent_ $ void `fmap` showEffects
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 17a4958..7cb6726 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -6,13 +6,14 @@ module Component.Select
 
 import           Data.Map   (Map)
 import           Data.Text  (Text)
-import           Reflex.Dom (Dynamic, MonadWidget, Reflex)
+import           Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom as R
 
 data (Reflex t) => SelectIn t a = SelectIn
   { _selectIn_label        :: Text
   , _selectIn_initialValue :: a
   , _selectIn_values       :: Dynamic t (Map a Text)
+  , _selectIn_reset        :: Event t ()
   }
 
 data SelectOut t a = SelectOut
@@ -24,8 +25,13 @@ select selectIn =
   R.divClass "selectInput" $ do
     R.el "label" $ R.text (_selectIn_label selectIn)
 
+    let initialValue = _selectIn_initialValue selectIn
+
     value <- R._dropdown_value <$>
-      R.dropdown (_selectIn_initialValue selectIn) (_selectIn_values selectIn) R.def
+      R.dropdown
+        initialValue
+        (_selectIn_values selectIn)
+        (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) })
 
     return SelectOut
       { _selectOut_value = value
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
index dae5e7f..1a45933 100644
--- a/client/src/Icon.hs
+++ b/client/src/Icon.hs
@@ -59,7 +59,7 @@ edit =
 
 loading :: forall t m. MonadWidget t m => m ()
 loading =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $
     svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
 
 signOut :: forall t m. MonadWidget t m => m ()
diff --git a/client/src/Main.hs b/client/src/Main.hs
index 6c048c6..d6f89cd 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -9,7 +9,8 @@ import qualified Data.Text.Encoding                   as T
 import qualified JSDOM                                as Dom
 import qualified JSDOM.Generated.HTMLElement          as Dom
 import qualified JSDOM.Generated.NonElementParentNode as Dom
-import           JSDOM.Types                          (HTMLElement (..), JSM)
+import           JSDOM.Types                          (HTMLElement (..), JSM,
+                                                       JSString)
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
@@ -26,7 +27,7 @@ main = do
 readInit :: JSM InitResult
 readInit = do
   document <- Dom.currentDocumentUnchecked
-  initNode <- Dom.getElementById document ("init" :: Dom.JSString)
+  initNode <- Dom.getElementById document ("init" :: JSString)
 
   case initNode of
     Just node -> do
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 14675df..0d76638 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -3,32 +3,42 @@ module Util.Ajax
   , delete
   ) where
 
-import           Data.Aeson    (ToJSON)
-import           Data.Default  (def)
-import qualified Data.Map.Lazy as LM
-import           Data.Text     (Text)
-import           Reflex.Dom    (Dynamic, Event, IsXhrPayload, MonadWidget,
-                                XhrRequest, XhrRequestConfig (..), XhrResponse,
-                                XhrResponseHeaders (..))
-import qualified Reflex.Dom    as R
+import           Control.Arrow      (left)
+import           Data.Aeson         (FromJSON, ToJSON)
+import qualified Data.Aeson         as Aeson
+import           Data.Default       (def)
+import qualified Data.Map.Lazy      as LM
+import           Data.Text          (Text)
+import qualified Data.Text          as T
+import qualified Data.Text.Encoding as T
+import           Reflex.Dom         (Dynamic, Event, IsXhrPayload, MonadWidget,
+                                     XhrRequest, XhrRequestConfig (..),
+                                     XhrResponse, XhrResponseHeaders (..))
+import qualified Reflex.Dom         as R
 
 postJson
-  :: forall t m a. (MonadWidget t m, ToJSON a)
+  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
-  -> m (Event t (Either Text Text))
+  -> m (Event t (Either Text b))
 postJson url input =
-  fmap getResult <$>
+  fmap getJsonResult <$>
     R.performRequestAsync (R.postJson url <$> input)
 
 delete
-  :: forall t m. MonadWidget t m
+  :: forall t m a. (MonadWidget t m)
   => Dynamic t Text
   -> Event t ()
   -> m (Event t (Either Text Text))
-delete url fire =
-  fmap getResult <$>
-    R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+delete url fire = do
+  response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+  return $ fmap getResult response
+
+getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
+getJsonResult response =
+  case getResult response of
+    Left l  -> Left l
+    Right r -> left T.pack . Aeson.eitherDecodeStrict $ (T.encodeUtf8 r)
 
 getResult :: XhrResponse -> Either Text Text
 getResult response =
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
new file mode 100644
index 0000000..2910d95
--- /dev/null
+++ b/client/src/Util/Either.hs
@@ -0,0 +1,7 @@
+module Util.Either
+  ( eitherToMaybe
+  ) where
+
+eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe (Right b) = Just b
+eitherToMaybe _         = Nothing
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 42da8fb..5245e72 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -4,17 +4,20 @@ module View.Payment
   , PaymentOut(..)
   ) where
 
+import           Data.Text           (Text)
+import qualified Data.Text           as T
 import           Prelude             hiding (init)
-import           Reflex.Dom          (MonadWidget)
+import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Init (..))
-
+import           Common.Model        (Frequency, Init (..), Payment (..),
+                                      PaymentId)
+import qualified Common.Util.Text    as T
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
 import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
 import qualified View.Payment.Pages  as Pages
-import           View.Payment.Table  (TableIn (..))
+import           View.Payment.Table  (TableIn (..), TableOut (..))
 import qualified View.Payment.Table  as Table
 
 data PaymentIn = PaymentIn
@@ -32,21 +35,63 @@ widget paymentIn = do
       let init = _paymentIn_init paymentIn
           paymentsPerPage = 7
 
+      payments <- getPayments
+        (_init_payments init)
+        (_headerOut_addedPayment header)
+        (_tableOut_deletedPayment table)
+
+      let searchPayments =
+            getSearchPayments
+              (_headerOut_searchName header)
+              (_headerOut_searchFrequency header)
+              payments
+
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
+        , _headerIn_searchPayments = searchPayments
         }
 
-      _ <- Table.widget $ TableIn
+      table <- Table.widget $ TableIn
         { _tableIn_init = init
         , _tableIn_currentPage = _pagesOut_currentPage pages
-        , _tableIn_payments = _headerOut_searchPayments header
+        , _tableIn_payments = searchPayments
         , _tableIn_perPage = paymentsPerPage
         }
 
       pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> _headerOut_searchPayments header
+        { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
-        , _pagesIn_reset = (fmap $ const ()) . R.updated $ _headerOut_searchName header
+        , _pagesIn_reset = R.leftmost $
+            [ fmap (const ()) . R.updated . _headerOut_searchName $ header
+            , fmap (const ()) . _headerOut_addedPayment $ header
+            ]
         }
 
     pure $ PaymentOut {}
+
+getPayments
+  :: forall t m. MonadWidget t m
+  => [Payment]
+  -> Event t Payment
+  -> Event t PaymentId
+  -> m (Dynamic t [Payment])
+getPayments initPayments addedPayment deletedPayment =
+  R.foldDyn id initPayments $ R.leftmost
+    [ flip fmap addedPayment (:)
+    , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    ]
+
+getSearchPayments
+  :: forall t. Reflex t
+  => Dynamic t Text
+  -> Dynamic t Frequency
+  -> Dynamic t [Payment]
+  -> Dynamic t [Payment]
+getSearchPayments name frequency payments = do
+  n <- name
+  f <- frequency
+  ps <- payments
+  pure $ flip filter ps (\p ->
+    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
+    && (_payment_frequency p == f)
+    ))
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 8b1b56e..602f7f3 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -10,12 +10,12 @@ import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
 import qualified Data.Time.Calendar     as Calendar
 import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Event, MonadWidget)
+import           Reflex.Dom             (Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 import qualified Text.Read              as T
 
 import           Common.Model           (Category (..), CreatePayment (..),
-                                         Frequency (..))
+                                         Frequency (..), Payment (..))
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as Time
 import           Component              (ButtonIn (..), InputIn (..),
@@ -23,48 +23,56 @@ import           Component              (ButtonIn (..), InputIn (..),
                                          SelectOut (..))
 import qualified Component              as Component
 import qualified Util.Ajax              as Ajax
+import qualified Util.Either            as EitherUtil
 import qualified Util.WaitFor           as WaitFor
 
-data AddIn = AddIn
+data AddIn t = AddIn
   { _addIn_categories :: [Category]
+  , _addIn_show       :: Event t ()
   }
 
 data AddOut t = AddOut
-  { _addOut_cancel :: Event t ()
+  { _addOut_cancel       :: Event t ()
+  , _addOut_addedPayment :: Event t Payment
   }
 
-view :: forall t m. MonadWidget t m => AddIn -> m (AddOut t)
+view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
 view addIn = do
   R.divClass "add" $ do
     R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
 
     R.divClass "addContent" $ do
-      name <- _inputOut_value <$> (Component.input $
-        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+      name <- _inputOut_value <$> (Component.input
+        (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+        (_addIn_show addIn))
 
-      cost <- _inputOut_value <$> (Component.input $
-        Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+      cost <- _inputOut_value <$> (Component.input
+        (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+        (_addIn_show addIn))
 
       currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
 
-      date <- _inputOut_value <$> (Component.input $
-        Component.defaultInputIn
+      date <- _inputOut_value <$> (Component.input
+        (Component.defaultInputIn
           { _inputIn_label = Msg.get Msg.Payment_Date
           , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
           , _inputIn_inputType = "date"
           , _inputIn_hasResetButton = False
           })
+        (_addIn_show addIn))
 
       frequency <- _selectOut_value <$> (Component.select $ SelectIn
         { _selectIn_label = Msg.get Msg.Payment_Frequency
         , _selectIn_initialValue = Punctual
         , _selectIn_values = R.constDyn frequencies
+        , _selectIn_reset = _addIn_show addIn
         })
 
       category <- _selectOut_value <$> (Component.select $ SelectIn
         { _selectIn_label = Msg.get Msg.Payment_Category
         , _selectIn_initialValue = 0
         , _selectIn_values = R.constDyn categories
+        , _selectIn_reset = _addIn_show addIn
         })
 
       let payment = CreatePayment
@@ -74,7 +82,7 @@ view addIn = do
             <*> category
             <*> frequency
 
-      cancel <- R.divClass "buttons" $ do
+      (addedPayment, cancel) <- R.divClass "buttons" $ do
         rec
           validate <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
@@ -83,17 +91,20 @@ view addIn = do
               , _buttonIn_submit = True
               })
 
-          (_, waiting) <- WaitFor.waitFor
+          (result, waiting) <- WaitFor.waitFor
             (Ajax.postJson "/payment")
             validate
             payment
 
-        Component._buttonOut_clic <$> (Component.button $
+        cancel <- Component._buttonOut_clic <$> (Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
             { _buttonIn_class = R.constDyn "undo" })
 
+        return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
+
       return AddOut
         { _addOut_cancel = cancel
+        , _addOut_addedPayment = addedPayment
         }
 
   where
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 03cf267..330ef9f 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,6 +4,7 @@ module View.Payment.Delete
   , DeleteOut(..)
   ) where
 
+import           Data.Text            (Text)
 import qualified Data.Text            as T
 import           Reflex.Dom           (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom           as R
@@ -13,6 +14,7 @@ import qualified Common.Msg           as Msg
 import           Component            (ButtonIn (..), ButtonOut (..))
 import qualified Component            as Component
 import qualified Util.Ajax            as Ajax
+import qualified Util.Either          as EitherUtil
 -- import qualified Util.WaitFor           as WaitFor
 
 data DeleteIn t = DeleteIn
@@ -20,7 +22,8 @@ data DeleteIn t = DeleteIn
   }
 
 data DeleteOut t = DeleteOut
-  { _deleteOut_cancel :: Event t ()
+  { _deleteOut_cancel   :: Event t ()
+  , _deleteOut_validate :: Event t PaymentId
   }
 
 view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
@@ -30,7 +33,7 @@ view deleteIn =
 
     R.divClass "deleteContent" $ do
 
-      cancel <- R.divClass "buttons" $ do
+      (deletedPayment, cancel) <- R.divClass "buttons" $ do
         rec
           confirm <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
@@ -41,7 +44,8 @@ view deleteIn =
           let url = flip fmap (_deleteIn_id deleteIn) (\id ->
                   T.concat ["/payment/", T.pack . show $ id]
                 )
-          Ajax.delete url confirm
+
+          result <- Ajax.delete url confirm
 
           -- (_, waiting) <- WaitFor.waitFor
           --   (Ajax.delete "/payment")
@@ -52,8 +56,9 @@ view deleteIn =
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
             { _buttonIn_class = R.constDyn "undo" })
 
-        return cancel
+        return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
 
       return DeleteOut
         { _deleteOut_cancel = cancel
+        , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment
         }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index be7f6d5..653df5e 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -13,7 +13,7 @@ import           Data.Text              (Text)
 import qualified Data.Text              as T
 import qualified Data.Time              as Time
 import           Prelude                hiding (init)
-import           Reflex.Dom             (Dynamic, MonadWidget, Reflex)
+import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
 import           Common.Model           (Category, Currency,
@@ -22,7 +22,6 @@ import           Common.Model           (Category, Currency,
                                          User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
-import qualified Common.Util.Text       as T
 import qualified Common.View.Format     as Format
 
 import           Component              (ButtonIn (..), ButtonOut (..),
@@ -34,44 +33,47 @@ import           View.Payment.Add       (AddIn (..), AddOut (..))
 import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init :: Init
+  { _headerIn_init           :: Init
+  , _headerIn_searchPayments :: Dynamic t [Payment]
   }
 
 data HeaderOut t = HeaderOut
-  { _headerOut_searchName     :: Dynamic t Text
-  , _headerOut_searchPayments :: Dynamic t [Payment]
+  { _headerOut_searchName      :: Dynamic t Text
+  , _headerOut_searchFrequency :: Dynamic t Frequency
+  , _headerOut_addedPayment    :: Event t Payment
   }
 
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    payerAndAdd incomes punctualPayments users categories currency
-    (searchName, searchFrequency)  <- searchLine
-    let searchPayments = getSearchPayments searchName searchFrequency payments
-    infos searchPayments users currency
+    addedPayment <- payerAndAdd incomes punctualPayments users categories currency
+    let resetSearchName = fmap (const ()) $ addedPayment
+    (searchName, searchFrequency)  <- searchLine resetSearchName
+
+    infos (_headerIn_searchPayments headerIn) users currency
+
     return $ HeaderOut
       { _headerOut_searchName = searchName
-      , _headerOut_searchPayments = searchPayments
+      , _headerOut_searchFrequency = searchFrequency
+      , _headerOut_addedPayment = addedPayment
       }
   where
     init = _headerIn_init headerIn
     incomes = _init_incomes init
-    payments = _init_payments init
-    punctualPayments = filter ((==) Punctual . _payment_frequency) payments
+    initPayments = _init_payments init
+    punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments
     users = _init_users init
     categories = _init_categories init
     currency = _init_currency init
 
-getSearchPayments :: forall t. (Reflex t) => Dynamic t Text -> Dynamic t Frequency -> [Payment] -> Dynamic t [Payment]
-getSearchPayments name frequency payments = do
-  n <- name
-  f <- frequency
-  pure $ flip filter payments (\p ->
-    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
-    && (_payment_frequency p == f)
-    ))
-
-payerAndAdd :: forall t m. MonadWidget t m => [Income] -> [Payment] -> [User] -> [Category] -> Currency -> m ()
+payerAndAdd
+  :: forall t m. MonadWidget t m
+  => [Income]
+  -> [Payment]
+  -> [User]
+  -> [Category]
+  -> Currency
+  -> m (Event t Payment)
 payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
@@ -94,19 +96,28 @@ payerAndAdd incomes payments users categories currency = do
       , _buttonIn_submit = False
       })
     rec
-      modalOut <- Component.modal $ ModalIn
+      modalOut <- fmap _modalOut_content . Component.modal $ ModalIn
         { _modalIn_show    = addPaymentClic
-        , _modalIn_hide = _addOut_cancel . _modalOut_content $ modalOut
-        , _modalIn_content = Add.view $ AddIn { _addIn_categories = categories }
+        , _modalIn_hide = R.leftmost $
+            [ _addOut_cancel modalOut
+            , fmap (const ()) . _addOut_addedPayment $ modalOut
+            ]
+        , _modalIn_content = Add.view $ AddIn
+            { _addIn_categories = categories
+            , _addIn_show = addPaymentClic
+            }
         }
-    return ()
+    return (_addOut_addedPayment modalOut)
 
-searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text, Dynamic t Frequency)
-searchLine = do
+searchLine
+  :: forall t m. MonadWidget t m
+  => Event t ()
+  -> m (Dynamic t Text, Dynamic t Frequency)
+searchLine reset = do
   R.divClass "searchLine" $ do
-    searchName <- _inputOut_value <$> (Component.input $ Component.defaultInputIn
-      { _inputIn_label = Msg.get Msg.Search_Name
-      })
+    searchName <- _inputOut_value <$> (Component.input
+      ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
+      reset)
 
     let frequencies = M.fromList
           [ (Punctual, Msg.get Msg.Payment_PunctualMale)
@@ -118,7 +129,11 @@ searchLine = do
 
     return (searchName, searchFrequency)
 
-infos :: forall t m. MonadWidget t m => Dynamic t [Payment] -> [User] -> Currency -> m ()
+infos
+  :: forall t m. MonadWidget t m
+  => Dynamic t [Payment]
+  -> [User]
+  -> Currency -> m ()
 infos payments users currency =
   R.divClass "infos" $ do
 
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index d14b640..57d67ac 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -64,7 +64,7 @@ pageButtons total perPage reset = do
     return currentPage
 
     where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
-          pageEvent = R.switchPromptlyDyn . fmap R.leftmost
+          pageEvent = R.switch . R.current . fmap R.leftmost
           noCurrentPage = R.constDyn Nothing
 
 range :: Int -> Int -> [Int]
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 13cedda..ba16bf5 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -9,11 +9,12 @@ 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           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
 import           Common.Model        (Category (..), Init (..), Payment (..),
-                                      PaymentCategory (..), User (..))
+                                      PaymentCategory (..), PaymentId,
+                                      User (..))
 import qualified Common.Model        as CM
 import qualified Common.Msg          as Msg
 import qualified Common.Util.Text    as T
@@ -34,15 +35,15 @@ data TableIn t = TableIn
   , _tableIn_perPage     :: Int
   }
 
-data TableOut = TableOut
-  {
+data TableOut t = TableOut
+  { _tableOut_deletedPayment :: Event t PaymentId
   }
 
-widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut
+widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    R.divClass "lines" $ do
+    deletedPayment <- R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
         R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -52,13 +53,14 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      _ <- R.simpleList paymentRange (paymentRow init)
-      return ()
+      (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init))
 
     Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
-  return $ TableOut {}
+    return $ TableOut
+      { _tableOut_deletedPayment = deletedPayment
+      }
 
   where
     init = _tableIn_init tableIn
@@ -74,7 +76,7 @@ getPaymentRange perPage payments currentPage =
     . L.sortOn _payment_date
     $ payments
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m ()
+paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId)
 paymentRow init payment =
   R.divClass "row" $ do
     R.divClass "cell name" . R.dynText . fmap _payment_name $ payment
@@ -117,10 +119,13 @@ paymentRow init payment =
     rec
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
-        , _modalIn_hide = _deleteOut_cancel . _modalOut_content $ modalOut
+        , _modalIn_hide = R.leftmost $
+            [ _deleteOut_cancel . _modalOut_content $ modalOut
+            , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut
+            ]
         , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
         }
-    return ()
+    return (_deleteOut_validate . _modalOut_content $ modalOut)
 
 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 24e5be0..7f53299 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -28,13 +28,9 @@ view signInMessage =
   R.divClass "signIn" $
     Component.form $ do
       rec
-        input <- Component.input $ InputIn
-          { _inputIn_reset = R.ffilter Either.isRight signInResult
-          , _inputIn_hasResetButton = True
-          , _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-          , _inputIn_initialValue = ""
-          , _inputIn_inputType = "text"
-          }
+        input <- (Component.input
+          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel })
+          (R.ffilter Either.isRight signInResult))
 
         button <- Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
-- 
cgit v1.2.3


From 8a28f608d8e08fba4bbe54b46804d261686c3c03 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 20:33:17 +0100
Subject: Upgrade reflex-platform

---
 client/src/Util/Ajax.hs           | 2 +-
 client/src/Util/WaitFor.hs        | 2 +-
 client/src/View/Payment/Header.hs | 1 +
 3 files changed, 3 insertions(+), 2 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 0d76638..7b65c52 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -31,7 +31,7 @@ delete
   -> Event t ()
   -> m (Event t (Either Text Text))
 delete url fire = do
-  response <- R.performRequestAsync (R.attachPromptlyDynWith (\u _ -> request "DELETE" u ()) url fire)
+  response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
   return $ fmap getResult response
 
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 0175c95..7d5e7c5 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -13,6 +13,6 @@ waitFor
   -> Dynamic t a
   -> m (Event t b, Event t Bool)
 waitFor op start input = do
-  result <- op (R.tagPromptlyDyn input start) >>= R.debounce (0.5 :: NominalDiffTime)
+  result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime)
   let waiting = R.leftmost [ const True <$> start , const False <$> result ]
   return (result, waiting)
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 653df5e..6fbaecf 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -11,6 +11,7 @@ import qualified Data.Map               as M
 import           Data.Maybe             (fromMaybe)
 import           Data.Text              (Text)
 import qualified Data.Text              as T
+import           Data.Time              (NominalDiffTime)
 import qualified Data.Time              as Time
 import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
-- 
cgit v1.2.3


From b5244184920b4d7a8d64eada2eca21e9a6ea2df9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 30 Oct 2018 20:44:12 +0100
Subject: Use waitfor with delete confirm button

---
 client/src/Util/WaitFor.hs        |  9 ++++-----
 client/src/View/Payment/Add.hs    |  3 +--
 client/src/View/Payment/Delete.hs | 12 +++++-------
 client/src/View/SignIn.hs         |  3 +--
 4 files changed, 11 insertions(+), 16 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 7d5e7c5..46882aa 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -9,10 +9,9 @@ import qualified Reflex.Dom as R
 waitFor
   :: forall t m a b. MonadWidget t m
   => (Event t a -> m (Event t b))
-  -> Event t ()
-  -> Dynamic t a
+  -> Event t a
   -> m (Event t b, Event t Bool)
-waitFor op start input = do
-  result <- op (R.tag (R.current input) start) >>= R.debounce (0.5 :: NominalDiffTime)
-  let waiting = R.leftmost [ const True <$> start , const False <$> result ]
+waitFor op input = do
+  result <- op input >>= R.debounce (0.2 :: NominalDiffTime)
+  let waiting = R.leftmost [ const True <$> input , const False <$> result ]
   return (result, waiting)
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 602f7f3..1864e76 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -93,8 +93,7 @@ view addIn = do
 
           (result, waiting) <- WaitFor.waitFor
             (Ajax.postJson "/payment")
-            validate
-            payment
+            (R.tag (R.current payment) validate)
 
         cancel <- Component._buttonOut_clic <$> (Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 330ef9f..81c7c57 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -15,7 +15,7 @@ import           Component            (ButtonIn (..), ButtonOut (..))
 import qualified Component            as Component
 import qualified Util.Ajax            as Ajax
 import qualified Util.Either          as EitherUtil
--- import qualified Util.WaitFor           as WaitFor
+import qualified Util.WaitFor         as WaitFor
 
 data DeleteIn t = DeleteIn
   { _deleteIn_id :: Dynamic t PaymentId
@@ -39,18 +39,16 @@ view deleteIn =
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
               { _buttonIn_class = R.constDyn "confirm"
               , _buttonIn_submit = True
+              , _buttonIn_waiting = waiting
               })
 
           let url = flip fmap (_deleteIn_id deleteIn) (\id ->
                   T.concat ["/payment/", T.pack . show $ id]
                 )
 
-          result <- Ajax.delete url confirm
-
-          -- (_, waiting) <- WaitFor.waitFor
-          --   (Ajax.delete "/payment")
-          --   validate
-          --   payment
+          (result, waiting) <- WaitFor.waitFor
+            (Ajax.delete url)
+            confirm
 
         cancel <- Component._buttonOut_clic <$> (Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 7f53299..428997e 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -41,8 +41,7 @@ view signInMessage =
 
         (signInResult, waiting) <- WaitFor.waitFor
           (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email))
-          (_buttonOut_clic button)
-          (_inputOut_value input)
+          (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button))
 
       showSignInResult signInMessage signInResult
 
-- 
cgit v1.2.3


From 86957359ecf54c205aee1c09e151172c327e987a Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 31 Oct 2018 19:03:19 +0100
Subject: Various fixes

---
 client/src/Util/WaitFor.hs     |   2 +-
 client/src/View/Payment/Add.hs | 115 +++++++++++++++++++++--------------------
 2 files changed, 59 insertions(+), 58 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 46882aa..02edff5 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -12,6 +12,6 @@ waitFor
   -> Event t a
   -> m (Event t b, Event t Bool)
 waitFor op input = do
-  result <- op input >>= R.debounce (0.2 :: NominalDiffTime)
+  result <- op input >>= R.debounce (0.5 :: NominalDiffTime)
   let waiting = R.leftmost [ const True <$> input , const False <$> result ]
   return (result, waiting)
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 1864e76..061eeeb 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -42,64 +42,65 @@ view addIn = do
     R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
 
     R.divClass "addContent" $ do
-      name <- _inputOut_value <$> (Component.input
-        (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
-        (_addIn_show addIn))
-
-      cost <- _inputOut_value <$> (Component.input
-        (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
-        (_addIn_show addIn))
-
-      currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
-
-      date <- _inputOut_value <$> (Component.input
-        (Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Payment_Date
-          , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
-          , _inputIn_inputType = "date"
-          , _inputIn_hasResetButton = False
+      rec
+        name <- _inputOut_value <$> (Component.input
+          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
+          (const () <$ addedPayment))
+
+        cost <- _inputOut_value <$> (Component.input
+          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
+          (const () <$ addedPayment))
+
+        currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+
+        date <- _inputOut_value <$> (Component.input
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Payment_Date
+            , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
+            , _inputIn_inputType = "date"
+            , _inputIn_hasResetButton = False
+            })
+          (const () <$ addedPayment))
+
+        frequency <- _selectOut_value <$> (Component.select $ SelectIn
+          { _selectIn_label = Msg.get Msg.Payment_Frequency
+          , _selectIn_initialValue = Punctual
+          , _selectIn_values = R.constDyn frequencies
+          , _selectIn_reset = _addIn_show addIn
           })
-        (_addIn_show addIn))
-
-      frequency <- _selectOut_value <$> (Component.select $ SelectIn
-        { _selectIn_label = Msg.get Msg.Payment_Frequency
-        , _selectIn_initialValue = Punctual
-        , _selectIn_values = R.constDyn frequencies
-        , _selectIn_reset = _addIn_show addIn
-        })
-
-      category <- _selectOut_value <$> (Component.select $ SelectIn
-        { _selectIn_label = Msg.get Msg.Payment_Category
-        , _selectIn_initialValue = 0
-        , _selectIn_values = R.constDyn categories
-        , _selectIn_reset = _addIn_show addIn
-        })
-
-      let payment = CreatePayment
-            <$> name
-            <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
-            <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
-            <*> category
-            <*> frequency
-
-      (addedPayment, cancel) <- R.divClass "buttons" $ do
-        rec
-          validate <- Component._buttonOut_clic <$> (Component.button $
-            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
-              { _buttonIn_class = R.constDyn "confirm"
-              , _buttonIn_waiting = waiting
-              , _buttonIn_submit = True
-              })
-
-          (result, waiting) <- WaitFor.waitFor
-            (Ajax.postJson "/payment")
-            (R.tag (R.current payment) validate)
-
-        cancel <- Component._buttonOut_clic <$> (Component.button $
-          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-            { _buttonIn_class = R.constDyn "undo" })
-
-        return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
+
+        category <- _selectOut_value <$> (Component.select $ SelectIn
+          { _selectIn_label = Msg.get Msg.Payment_Category
+          , _selectIn_initialValue = 0
+          , _selectIn_values = R.constDyn categories
+          , _selectIn_reset = _addIn_show addIn
+          })
+
+        let payment = CreatePayment
+              <$> name
+              <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
+              <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
+              <*> category
+              <*> frequency
+
+        (addedPayment, cancel) <- R.divClass "buttons" $ do
+          rec
+            validate <- Component._buttonOut_clic <$> (Component.button $
+              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+                { _buttonIn_class = R.constDyn "confirm"
+                , _buttonIn_waiting = waiting
+                , _buttonIn_submit = True
+                })
+
+            (result, waiting) <- WaitFor.waitFor
+              (Ajax.postJson "/payment")
+              (R.tag (R.current payment) validate)
+
+          cancel <- Component._buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+              { _buttonIn_class = R.constDyn "undo" })
+
+          return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
 
       return AddOut
         { _addOut_cancel = cancel
-- 
cgit v1.2.3


From 2741f47ef7b87255203bc2f7f7b2b9140c70b8f0 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 1 Nov 2018 13:14:25 +0100
Subject: Implementing client side validation

---
 client/src/Component/Input.hs     | 114 +++++++++++++++++++++++-----------
 client/src/Component/Modal.hs     |  19 +++---
 client/src/Component/Select.hs    |  61 +++++++++++++-----
 client/src/Util/Validation.hs     |  37 +++++++++++
 client/src/View/App.hs            |   3 +-
 client/src/View/Payment.hs        |   2 +-
 client/src/View/Payment/Add.hs    | 127 ++++++++++++++++++++++++--------------
 client/src/View/Payment/Header.hs |  16 ++---
 client/src/View/Payment/Pages.hs  |   2 +-
 client/src/View/SignIn.hs         |  48 ++++++++------
 10 files changed, 296 insertions(+), 133 deletions(-)
 create mode 100644 client/src/Util/Validation.hs

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 57018a6..67f97c0 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -5,59 +5,91 @@ module Component.Input
   , defaultInputIn
   ) where
 
-import qualified Data.Map         as M
-import           Data.Text        (Text)
-import qualified Data.Text        as T
-import           Reflex.Dom       (Dynamic, Event, MonadWidget, Reflex, (&),
-                                   (.~))
-import qualified Reflex.Dom       as R
-
-import           Component.Button (ButtonIn (..), ButtonOut (..))
-import qualified Component.Button as Button
+import qualified Data.Map               as M
+import qualified Data.Maybe             as Maybe
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import           Data.Time              (NominalDiffTime)
+import           Data.Validation        (Validation (Failure, Success))
+import qualified Data.Validation        as V
+import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex,
+                                         (&), (.~))
+import qualified Reflex.Dom             as R
+
+import qualified Common.Util.Validation as ValidationUtil
+import           Component.Button       (ButtonIn (..), ButtonOut (..))
+import qualified Component.Button       as Button
 import qualified Icon
 
-data InputIn = InputIn
+data InputIn a = InputIn
   { _inputIn_hasResetButton :: Bool
   , _inputIn_label          :: Text
   , _inputIn_initialValue   :: Text
   , _inputIn_inputType      :: Text
+  , _inputIn_validation     :: Text -> Validation Text a
   }
 
-defaultInputIn :: InputIn
+defaultInputIn :: InputIn Text
 defaultInputIn = InputIn
   { _inputIn_hasResetButton = True
   , _inputIn_label          = ""
   , _inputIn_initialValue   = ""
   , _inputIn_inputType      = "text"
+  , _inputIn_validation     = V.Success
   }
 
-data InputOut t = InputOut
-  { _inputOut_value :: Dynamic t Text
+data InputOut t a = InputOut
+  { _inputOut_raw   :: Dynamic t Text
+  , _inputOut_value :: Dynamic t (Maybe (Validation Text a))
   , _inputOut_enter :: Event t ()
   }
 
 input
   :: forall t m a b. MonadWidget t m
-  => InputIn
-  -> Event t a -- reset
-  -> m (InputOut t)
-input inputIn reset =
-  R.divClass "textInput" $ do
-    rec
-      let resetValue = R.leftmost
-            [ fmap (const "") reset
-            , fmap (const "") resetClic
-            ]
-
-          attributes = R.ffor value (\v ->
-            if T.null v && _inputIn_inputType inputIn /= "date"
-              then M.empty
-              else M.singleton "class" "filled")
-
-          value =  R._textInput_value textInput
+  => InputIn a
+  -> Event t Text -- reset
+  -> Event t b    -- validate
+  -> m (InputOut t a)
+input inputIn reset validate = do
+  rec
+    let resetValue = R.leftmost
+          [ R.traceEvent "reset" reset
+          , fmap (const "") resetClic
+          ]
+
+        inputAttr = R.ffor value (\v ->
+          if T.null v && _inputIn_inputType inputIn /= "date"
+            then M.empty
+            else M.singleton "class" "filled")
+
+        value =  R._textInput_value textInput
+
+        containerAttr = R.ffor validatedValue (\v ->
+          M.singleton "class" $ T.intercalate " "
+            [ "textInput"
+            , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else ""
+            ])
+
+    -- Clear validation errors after reset
+    delayedReset <- R.delay (0.1 :: NominalDiffTime) reset
+
+    validatedValue <- R.holdDyn Nothing $ R.attachWith
+      (\v (clearValidation, validateEmpty) ->
+        if clearValidation
+           then Nothing
+           else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v)))
+      (R.current value)
+      (R.leftmost
+        [ const (False, True) <$> resetClic
+        , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput)
+        , const (False, False) <$> validate
+        , const (True, False) <$> R.traceEvent "delayedReset" delayedReset
+        ])
+
+    (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
 
       textInput <- R.textInput $ R.def
-        & R.attributes .~ attributes
+        & R.attributes .~ inputAttr
         & R.setValue .~ resetValue
         & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
         & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
@@ -75,9 +107,19 @@ input inputIn reset =
           else
             return R.never
 
-    let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+      R.divClass "errorMessage" $
+        R.dynText . fmap validationError $ validatedValue
+
+      return (textInput, resetClic)
+
+  let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+
+  return $ InputOut
+    { _inputOut_raw = value
+    , _inputOut_value = validatedValue
+    , _inputOut_enter = enter
+    }
 
-    return $ InputOut
-      { _inputOut_value = value
-      , _inputOut_enter = enter
-      }
+validationError :: Maybe (Validation Text a) -> Text
+validationError (Just (Failure e)) = e
+validationError _                  = ""
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index b86fee0..d7943a9 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -23,11 +23,12 @@ data ModalIn t m a = ModalIn
   , _modalIn_content :: m a
   }
 
-data ModalOut a = ModalOut
+data ModalOut t a = ModalOut
   { _modalOut_content :: a
+  , _modalOut_hide    :: Event t ()
   }
 
-modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut a)
+modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a)
 modal modalIn = do
   rec
     let showEvent = R.leftmost
@@ -48,6 +49,7 @@ modal modalIn = do
 
   return $ ModalOut
     { _modalOut_content = content
+    , _modalOut_hide = curtainClick
     }
 
 getAttributes :: Bool -> LM.Map Text Text
@@ -67,12 +69,13 @@ performShowEffects showEvent elem = do
 
   let showEffects =
         flip fmap showEvent (\show -> do
-          if show
-            then
-              do
-                Node.appendChild body elem
-                Element.setClassName body ("modal" :: JSString)
-            else
+          if show then
+            do
+              Node.appendChild body elem
+              Element.setClassName body ("modal" :: JSString)
+          else
+            do
+              Node.removeChild body elem
               Element.setClassName body ("" :: JSString)
         )
 
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 7cb6726..9f671d3 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -5,34 +5,65 @@ module Component.Select
   ) where
 
 import           Data.Map   (Map)
+import qualified Data.Map   as M
 import           Data.Text  (Text)
+import qualified Data.Text  as T
 import           Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom as R
 
-data (Reflex t) => SelectIn t a = SelectIn
+import qualified Common.Msg as Msg
+
+data (Reflex t) => SelectIn t a b c = SelectIn
   { _selectIn_label        :: Text
   , _selectIn_initialValue :: a
   , _selectIn_values       :: Dynamic t (Map a Text)
-  , _selectIn_reset        :: Event t ()
+  , _selectIn_reset        :: Event t b
+  , _selectIn_isValid      :: a -> Bool
+  , _selectIn_validate     :: Event t c
   }
 
 data SelectOut t a = SelectOut
   { _selectOut_value :: Dynamic t a
   }
 
-select :: forall t m a. (Ord a, MonadWidget t m) => SelectIn t a -> m (SelectOut t a)
-select selectIn =
-  R.divClass "selectInput" $ do
-    R.el "label" $ R.text (_selectIn_label selectIn)
+select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a)
+select selectIn = do
+  rec
+    let containerAttr = R.ffor hasError (\e ->
+          M.singleton "class" $ T.intercalate " "
+            [ "selectInput"
+            , if e then "error" else ""
+            ])
+
+    hasError <- R.holdDyn False $ R.attachWith
+      (\v clearError -> not clearError && not (_selectIn_isValid selectIn v))
+      (R.current value)
+      (R.leftmost
+        [ const False <$> _selectIn_validate selectIn
+        , const True <$> _selectIn_reset selectIn
+        ])
+
+    value <- R.elDynAttr "div" containerAttr $ do
+      R.el "label" $ R.text (_selectIn_label selectIn)
+
+      let initialValue = _selectIn_initialValue selectIn
+
+      value <- R._dropdown_value <$>
+        R.dropdown
+          initialValue
+          (_selectIn_values selectIn)
+          (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) })
+
+      errorMessage <- R.holdDyn "" $ R.attachWith
+        (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!")
+        (R.current value)
+        (_selectIn_validate selectIn)
 
-    let initialValue = _selectIn_initialValue selectIn
+      R.divClass "errorMessage" . R.dynText $
+        R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "")
 
-    value <- R._dropdown_value <$>
-      R.dropdown
-        initialValue
-        (_selectIn_values selectIn)
-        (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) })
+      return value
 
-    return SelectOut
-      { _selectOut_value = value
-      }
+  return SelectOut
+    { _selectOut_value = value
+    }
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
new file mode 100644
index 0000000..e2a3dcb
--- /dev/null
+++ b/client/src/Util/Validation.hs
@@ -0,0 +1,37 @@
+module Util.Validation
+  ( fireValidation
+  , fireMaybe
+  , nelError
+  ) where
+
+import           Control.Monad      (join)
+import           Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NEL
+import           Data.Text          (Text)
+import           Data.Validation    (Validation (Failure, Success))
+import qualified Data.Validation    as Validation
+import           Reflex.Dom         (Dynamic, Event, Reflex)
+import qualified Reflex.Dom         as R
+
+nelError :: Validation a b -> Validation (NonEmpty a) b
+nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success
+
+fireValidation
+  :: forall t a b c. Reflex t
+  => Dynamic t (Maybe (Validation a b))
+  -> Event t c
+  -> Event t b
+fireValidation value validate =
+  R.fmapMaybe
+    (join . fmap (Validation.validation (const Nothing) Just))
+    (R.tag (R.current value) validate)
+
+fireMaybe
+  :: forall t a b. Reflex t
+  => Dynamic t (Maybe a)
+  -> Event t b
+  -> Event t a
+fireMaybe value validate =
+  R.fmapMaybe
+    id
+    (R.tag (R.current value) validate)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 9aa6c57..6435297 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -16,7 +16,8 @@ import qualified View.SignIn  as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
-  R.mainWidget $ do
+  R.mainWidget $ R.divClass "app" $ do
+
     headerOut <- Header.view $ HeaderIn
       { _headerIn_initResult = initResult
       }
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 5245e72..007471d 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -30,7 +30,7 @@ data PaymentOut = PaymentOut
 
 widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
 widget paymentIn = do
-  R.divClass "payment" $ do
+  R.elClass "main" "payment" $ do
     rec
       let init = _paymentIn_init paymentIn
           paymentsPerPage = 7
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 061eeeb..62b26a3 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -4,31 +4,34 @@ module View.Payment.Add
   , AddOut(..)
   ) where
 
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.Map               as M
-import qualified Data.Maybe             as Maybe
-import qualified Data.Text              as T
-import qualified Data.Time.Calendar     as Calendar
-import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Event, MonadWidget, Reflex)
-import qualified Reflex.Dom             as R
-import qualified Text.Read              as T
-
-import           Common.Model           (Category (..), CreatePayment (..),
-                                         Frequency (..), Payment (..))
-import qualified Common.Msg             as Msg
-import qualified Common.Util.Time       as Time
-import           Component              (ButtonIn (..), InputIn (..),
-                                         InputOut (..), SelectIn (..),
-                                         SelectOut (..))
-import qualified Component              as Component
-import qualified Util.Ajax              as Ajax
-import qualified Util.Either            as EitherUtil
-import qualified Util.WaitFor           as WaitFor
+import           Control.Monad.IO.Class    (liftIO)
+import qualified Data.Map                  as M
+import qualified Data.Maybe                as Maybe
+import qualified Data.Text                 as T
+import qualified Data.Time.Calendar        as Calendar
+import qualified Data.Time.Clock           as Time
+import qualified Data.Validation           as V
+import           Reflex.Dom                (Event, MonadWidget, Reflex)
+import qualified Reflex.Dom                as R
+import qualified Text.Read                 as T
+
+import           Common.Model              (Category (..), CreatePayment (..),
+                                            Frequency (..), Payment (..))
+import qualified Common.Msg                as Msg
+import qualified Common.Util.Time          as Time
+import qualified Common.Validation.Payment as PaymentValidation
+import           Component                 (ButtonIn (..), InputIn (..),
+                                            InputOut (..), SelectIn (..),
+                                            SelectOut (..))
+import qualified Component                 as Component
+import qualified Util.Ajax                 as Ajax
+import qualified Util.Either               as EitherUtil
+import qualified Util.Validation           as ValidationUtil
+import qualified Util.WaitFor              as WaitFor
 
 data AddIn t = AddIn
   { _addIn_categories :: [Category]
-  , _addIn_show       :: Event t ()
+  , _addIn_cancel     :: Event t ()
   }
 
 data AddOut t = AddOut
@@ -43,48 +46,84 @@ view addIn = do
 
     R.divClass "addContent" $ do
       rec
+        let reset = R.leftmost
+              [ const "" <$> cancel
+              , const "" <$> addedPayment
+              , const "" <$> _addIn_cancel addIn
+              ]
+
         name <- _inputOut_value <$> (Component.input
-          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Name })
-          (const () <$ addedPayment))
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Payment_Name
+            , _inputIn_validation = PaymentValidation.name
+            })
+          reset
+          validate)
 
         cost <- _inputOut_value <$> (Component.input
-          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.Payment_Cost })
-          (const () <$ addedPayment))
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Payment_Cost
+            , _inputIn_validation = PaymentValidation.cost
+            })
+          reset
+          validate)
 
-        currentDay <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+        currentDay <- do
+          d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+          return . T.pack . Calendar.showGregorian $ d
 
         date <- _inputOut_value <$> (Component.input
           (Component.defaultInputIn
             { _inputIn_label = Msg.get Msg.Payment_Date
-            , _inputIn_initialValue = T.pack . Calendar.showGregorian $ currentDay
+            , _inputIn_initialValue = currentDay
             , _inputIn_inputType = "date"
             , _inputIn_hasResetButton = False
+            , _inputIn_validation = PaymentValidation.date
             })
-          (const () <$ addedPayment))
+          (const currentDay <$> reset)
+          validate)
 
         frequency <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Frequency
           , _selectIn_initialValue = Punctual
           , _selectIn_values = R.constDyn frequencies
-          , _selectIn_reset = _addIn_show addIn
+          , _selectIn_reset = reset
+          , _selectIn_isValid = const True
+          , _selectIn_validate = validate
           })
 
         category <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Category
-          , _selectIn_initialValue = 0
+          , _selectIn_initialValue = -1
           , _selectIn_values = R.constDyn categories
-          , _selectIn_reset = _addIn_show addIn
+          , _selectIn_reset = reset
+          , _selectIn_isValid = \id -> id /= -1
+          , _selectIn_validate = validate
           })
 
-        let payment = CreatePayment
-              <$> name
-              <*> fmap (Maybe.fromMaybe 0 . T.readMaybe . T.unpack) cost
-              <*> fmap (Maybe.fromMaybe currentDay . Time.parseDay) date
-              <*> category
-              <*> frequency
-
-        (addedPayment, cancel) <- R.divClass "buttons" $ do
+        let payment = do
+              n <- name
+              c <- cost
+              d <- date
+              cat <- category
+              f <- frequency
+              pure $ do
+                n' <- n
+                c' <- c
+                d' <- d
+                pure $ CreatePayment
+                  <$> ValidationUtil.nelError n'
+                  <*> ValidationUtil.nelError c'
+                  <*> ValidationUtil.nelError d'
+                  <*> ValidationUtil.nelError (V.Success cat)
+                  <*> ValidationUtil.nelError (V.Success f)
+
+        (addedPayment, cancel, validate) <- R.divClass "buttons" $ do
           rec
+            cancel <- Component._buttonOut_clic <$> (Component.button $
+              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+                { _buttonIn_class = R.constDyn "undo" })
+
             validate <- Component._buttonOut_clic <$> (Component.button $
               (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
                 { _buttonIn_class = R.constDyn "confirm"
@@ -94,13 +133,9 @@ view addIn = do
 
             (result, waiting) <- WaitFor.waitFor
               (Ajax.postJson "/payment")
-              (R.tag (R.current payment) validate)
-
-          cancel <- Component._buttonOut_clic <$> (Component.button $
-            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-              { _buttonIn_class = R.constDyn "undo" })
+              (ValidationUtil.fireValidation payment validate)
 
-          return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
+          return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate)
 
       return AddOut
         { _addOut_cancel = cancel
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 6fbaecf..56441eb 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -97,18 +97,19 @@ payerAndAdd incomes payments users categories currency = do
       , _buttonIn_submit = False
       })
     rec
-      modalOut <- fmap _modalOut_content . Component.modal $ ModalIn
+      modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = addPaymentClic
         , _modalIn_hide = R.leftmost $
-            [ _addOut_cancel modalOut
-            , fmap (const ()) . _addOut_addedPayment $ modalOut
+            [ _addOut_cancel addOut
+            , fmap (const ()) . _addOut_addedPayment $ addOut
             ]
         , _modalIn_content = Add.view $ AddIn
             { _addIn_categories = categories
-            , _addIn_show = addPaymentClic
+            , _addIn_cancel = _modalOut_hide modalOut
             }
         }
-    return (_addOut_addedPayment modalOut)
+      let addOut = _modalOut_content modalOut
+    return (_addOut_addedPayment addOut)
 
 searchLine
   :: forall t m. MonadWidget t m
@@ -116,9 +117,10 @@ searchLine
   -> m (Dynamic t Text, Dynamic t Frequency)
 searchLine reset = do
   R.divClass "searchLine" $ do
-    searchName <- _inputOut_value <$> (Component.input
+    searchName <- _inputOut_raw <$> (Component.input
       ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
-      reset)
+      (const "" <$> reset)
+      R.never)
 
     let frequencies = M.fromList
           [ (Punctual, Msg.get Msg.Payment_PunctualMale)
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 57d67ac..cbe7b50 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -47,7 +47,7 @@ pageButtons total perPage reset = do
         , pageClic
         , nextPageClic
         , lastPageClic
-        , (const 1) <$> reset
+        , 1 <$ reset
         ]
 
       firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 428997e..6fbf6d6 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -3,20 +3,24 @@ module View.SignIn
   , view
   ) where
 
-import qualified Data.Either  as Either
-import           Data.Text    (Text)
-import           Prelude      hiding (error)
-import           Reflex.Dom   (Event, MonadWidget)
-import qualified Reflex.Dom   as R
+import qualified Data.Either              as Either
+import qualified Data.Maybe               as Maybe
+import           Data.Text                (Text)
+import           Data.Validation          (Validation)
+import           Prelude                  hiding (error)
+import           Reflex.Dom               (Event, MonadWidget)
+import qualified Reflex.Dom               as R
 
-import           Common.Model (SignIn (SignIn))
-import qualified Common.Msg   as Msg
+import           Common.Model             (SignInForm (SignInForm))
+import qualified Common.Msg               as Msg
+import qualified Common.Validation.SignIn as SignInValidation
 
-import           Component    (ButtonIn (..), ButtonOut (..), InputIn (..),
-                               InputOut (..))
-import qualified Component    as Component
-import qualified Util.Ajax    as Ajax
-import qualified Util.WaitFor as WaitFor
+import           Component                (ButtonIn (..), ButtonOut (..),
+                                           InputIn (..), InputOut (..))
+import qualified Component                as Component
+import qualified Util.Ajax                as Ajax
+import qualified Util.Validation          as ValidationUtil
+import qualified Util.WaitFor             as WaitFor
 
 data SignInMessage =
   SuccessMessage Text
@@ -29,19 +33,27 @@ view signInMessage =
     Component.form $ do
       rec
         input <- (Component.input
-          (Component.defaultInputIn { _inputIn_label = Msg.get Msg.SignIn_EmailLabel })
-          (R.ffilter Either.isRight signInResult))
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.SignIn_EmailLabel
+            , _inputIn_validation = SignInValidation.email
+            })
+          (const "" <$> R.ffilter Either.isRight signInResult)
+          validate)
 
-        button <- Component.button $
+        validate <- _buttonOut_clic <$> (Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
             { _buttonIn_class = R.constDyn "validate"
             , _buttonIn_waiting = waiting
             , _buttonIn_submit = True
-            }
+            })
+
+        let form = SignInForm <$> _inputOut_raw input
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (\email -> Ajax.postJson "/askSignIn" (SignIn <$> email))
-          (R.tag (R.current (_inputOut_value input)) (_buttonOut_clic button))
+          (Ajax.postJson "/askSignIn")
+          (ValidationUtil.fireMaybe
+            ((\f -> const f <$> SignInValidation.signIn f) <$> form)
+            validate)
 
       showSignInResult signInMessage signInResult
 
-- 
cgit v1.2.3


From bc81084933f8ec1bfe6c2834defd12243117fdd9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 5 Aug 2019 21:53:30 +0200
Subject: Use updated payment categories from payment add in payment’s table

---
 client/src/Component/Input.hs     |  4 ++--
 client/src/View/Payment.hs        | 30 +++++++++++++++++++++++-------
 client/src/View/Payment/Add.hs    | 22 +++++++++++++---------
 client/src/View/Payment/Header.hs | 22 +++++++++++-----------
 client/src/View/Payment/Table.hs  | 31 +++++++++++++++++--------------
 5 files changed, 66 insertions(+), 43 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 67f97c0..d679f9b 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -53,7 +53,7 @@ input
 input inputIn reset validate = do
   rec
     let resetValue = R.leftmost
-          [ R.traceEvent "reset" reset
+          [ reset
           , fmap (const "") resetClic
           ]
 
@@ -83,7 +83,7 @@ input inputIn reset validate = do
         [ const (False, True) <$> resetClic
         , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput)
         , const (False, False) <$> validate
-        , const (True, False) <$> R.traceEvent "delayedReset" delayedReset
+        , const (True, False) <$> delayedReset
         ])
 
     (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 007471d..f614936 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -10,7 +10,8 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Frequency, Init (..), Payment (..),
+import           Common.Model        (CreatedPayment (..), Frequency, Init (..),
+                                      Payment (..), PaymentCategory (..),
                                       PaymentId)
 import qualified Common.Util.Text    as T
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
@@ -37,8 +38,12 @@ widget paymentIn = do
 
       payments <- getPayments
         (_init_payments init)
-        (_headerOut_addedPayment header)
-        (_tableOut_deletedPayment table)
+        (_createdPayment_payment <$> _headerOut_addPayment header)
+        (_tableOut_deletePayment table)
+
+      paymentCategories <- getPaymentCategories
+        (_init_paymentCategories init)
+        (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
 
       let searchPayments =
             getSearchPayments
@@ -56,6 +61,7 @@ widget paymentIn = do
         , _tableIn_currentPage = _pagesOut_currentPage pages
         , _tableIn_payments = searchPayments
         , _tableIn_perPage = paymentsPerPage
+        , _tableIn_paymentCategories = paymentCategories
         }
 
       pages <- Pages.widget $ PagesIn
@@ -63,7 +69,7 @@ widget paymentIn = do
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
             [ fmap (const ()) . R.updated . _headerOut_searchName $ header
-            , fmap (const ()) . _headerOut_addedPayment $ header
+            , fmap (const ()) . _headerOut_addPayment $ header
             ]
         }
 
@@ -75,10 +81,20 @@ getPayments
   -> Event t Payment
   -> Event t PaymentId
   -> m (Dynamic t [Payment])
-getPayments initPayments addedPayment deletedPayment =
+getPayments initPayments addPayment deletePayment =
   R.foldDyn id initPayments $ R.leftmost
-    [ flip fmap addedPayment (:)
-    , flip fmap deletedPayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    [ (:) <$> addPayment
+    , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    ]
+
+getPaymentCategories
+  :: forall t m. MonadWidget t m
+  => [PaymentCategory]
+  -> Event t PaymentCategory
+  -> m (Dynamic t [PaymentCategory])
+getPaymentCategories initPaymentCategories addPaymentCategory =
+  R.foldDyn id initPaymentCategories $ R.leftmost
+    [ (:) <$> addPaymentCategory
     ]
 
 getSearchPayments
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 62b26a3..2970394 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -16,7 +16,8 @@ import qualified Reflex.Dom                as R
 import qualified Text.Read                 as T
 
 import           Common.Model              (Category (..), CreatePayment (..),
-                                            Frequency (..), Payment (..))
+                                            CreatedPayment (..), Frequency (..),
+                                            Payment (..), PaymentCategory (..))
 import qualified Common.Msg                as Msg
 import qualified Common.Util.Time          as Time
 import qualified Common.Validation.Payment as PaymentValidation
@@ -35,8 +36,9 @@ data AddIn t = AddIn
   }
 
 data AddOut t = AddOut
-  { _addOut_cancel       :: Event t ()
-  , _addOut_addedPayment :: Event t Payment
+  { _addOut_cancel             :: Event t ()
+  , _addOut_addPayment         :: Event t CreatedPayment
+  , _addOut_addPaymentCategory :: Event t PaymentCategory
   }
 
 view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
@@ -48,7 +50,7 @@ view addIn = do
       rec
         let reset = R.leftmost
               [ const "" <$> cancel
-              , const "" <$> addedPayment
+              , const "" <$> addPayment
               , const "" <$> _addIn_cancel addIn
               ]
 
@@ -68,8 +70,10 @@ view addIn = do
           reset
           validate)
 
+        now <- liftIO Time.getCurrentTime
+
         currentDay <- do
-          d <- liftIO $ Time.getCurrentTime >>= Time.timeToDay
+          d <- liftIO $ Time.timeToDay now
           return . T.pack . Calendar.showGregorian $ d
 
         date <- _inputOut_value <$> (Component.input
@@ -118,7 +122,7 @@ view addIn = do
                   <*> ValidationUtil.nelError (V.Success cat)
                   <*> ValidationUtil.nelError (V.Success f)
 
-        (addedPayment, cancel, validate) <- R.divClass "buttons" $ do
+        (addPayment, cancel, validate) <- R.divClass "buttons" $ do
           rec
             cancel <- Component._buttonOut_clic <$> (Component.button $
               (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
@@ -131,15 +135,15 @@ view addIn = do
                 , _buttonIn_submit = True
                 })
 
-            (result, waiting) <- WaitFor.waitFor
+            (addPayment, waiting) <- WaitFor.waitFor
               (Ajax.postJson "/payment")
               (ValidationUtil.fireValidation payment validate)
 
-          return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel, validate)
+          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate)
 
       return AddOut
         { _addOut_cancel = cancel
-        , _addOut_addedPayment = addedPayment
+        , _addOut_addPayment = addPayment
         }
 
   where
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 56441eb..c49b284 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -17,10 +17,10 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Category, Currency,
-                                         ExceedingPayer (..), Frequency (..),
-                                         Income (..), Init (..), Payment (..),
-                                         User (..))
+import           Common.Model           (Category, CreatedPayment (..),
+                                         Currency, ExceedingPayer (..),
+                                         Frequency (..), Income (..), Init (..),
+                                         Payment (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -41,14 +41,14 @@ data HeaderIn t = HeaderIn
 data HeaderOut t = HeaderOut
   { _headerOut_searchName      :: Dynamic t Text
   , _headerOut_searchFrequency :: Dynamic t Frequency
-  , _headerOut_addedPayment    :: Event t Payment
+  , _headerOut_addPayment      :: Event t CreatedPayment
   }
 
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addedPayment <- payerAndAdd incomes punctualPayments users categories currency
-    let resetSearchName = fmap (const ()) $ addedPayment
+    addPayment <- payerAndAdd incomes punctualPayments users categories currency
+    let resetSearchName = fmap (const ()) $ addPayment
     (searchName, searchFrequency)  <- searchLine resetSearchName
 
     infos (_headerIn_searchPayments headerIn) users currency
@@ -56,7 +56,7 @@ widget headerIn =
     return $ HeaderOut
       { _headerOut_searchName = searchName
       , _headerOut_searchFrequency = searchFrequency
-      , _headerOut_addedPayment = addedPayment
+      , _headerOut_addPayment = addPayment
       }
   where
     init = _headerIn_init headerIn
@@ -74,7 +74,7 @@ payerAndAdd
   -> [User]
   -> [Category]
   -> Currency
-  -> m (Event t Payment)
+  -> m (Event t CreatedPayment)
 payerAndAdd incomes payments users categories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
@@ -101,7 +101,7 @@ payerAndAdd incomes payments users categories currency = do
         { _modalIn_show    = addPaymentClic
         , _modalIn_hide = R.leftmost $
             [ _addOut_cancel addOut
-            , fmap (const ()) . _addOut_addedPayment $ addOut
+            , fmap (const ()) . _addOut_addPayment $ addOut
             ]
         , _modalIn_content = Add.view $ AddIn
             { _addIn_categories = categories
@@ -109,7 +109,7 @@ payerAndAdd incomes payments users categories currency = do
             }
         }
       let addOut = _modalOut_content modalOut
-    return (_addOut_addedPayment addOut)
+    return (_addOut_addPayment addOut)
 
 searchLine
   :: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index ba16bf5..6432274 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -29,21 +29,22 @@ import qualified Icon
 import qualified Util.Dom            as Dom
 
 data TableIn t = TableIn
-  { _tableIn_init        :: Init
-  , _tableIn_currentPage :: Dynamic t Int
-  , _tableIn_payments    :: Dynamic t [Payment]
-  , _tableIn_perPage     :: Int
+  { _tableIn_init              :: Init
+  , _tableIn_currentPage       :: Dynamic t Int
+  , _tableIn_payments          :: Dynamic t [Payment]
+  , _tableIn_perPage           :: Int
+  , _tableIn_paymentCategories :: Dynamic t [PaymentCategory]
   }
 
 data TableOut t = TableOut
-  { _tableOut_deletedPayment :: Event t PaymentId
+  { _tableOut_deletePayment :: Event t PaymentId
   }
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    deletedPayment <- R.divClass "lines" $ do
+    deletePayment <- R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
         R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -53,13 +54,14 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      (R.switch . R.current . fmap R.leftmost) <$> (R.simpleList paymentRange (paymentRow init))
+      (R.switch . R.current . fmap R.leftmost) <$>
+        (R.simpleList paymentRange (paymentRow init paymentCategories))
 
     Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
     return $ TableOut
-      { _tableOut_deletedPayment = deletedPayment
+      { _tableOut_deletePayment = deletePayment
       }
 
   where
@@ -67,6 +69,7 @@ widget tableIn = do
     currentPage = _tableIn_currentPage tableIn
     payments = _tableIn_payments tableIn
     paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
+    paymentCategories = _tableIn_paymentCategories tableIn
 
 getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
 getPaymentRange perPage payments currentPage =
@@ -76,8 +79,8 @@ getPaymentRange perPage payments currentPage =
     . L.sortOn _payment_date
     $ payments
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m (Event t PaymentId)
-paymentRow init payment =
+paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId)
+paymentRow init paymentCategories payment =
   R.divClass "row" $ do
     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
@@ -88,10 +91,10 @@ paymentRow init payment =
         Just u -> _user_name u
         _      -> ""
 
-    let category = flip fmap payment $ \p -> findCategory
-          (_init_categories init)
-          (_init_paymentCategories init)
-          (_payment_name p)
+    let category = do
+          p <- payment
+          pcs <- paymentCategories
+          return $ findCategory (_init_categories init) pcs (_payment_name p)
     R.divClass "cell category" $ do
       let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of
             Just c -> M.fromList
-- 
cgit v1.2.3


From fc8be14dd0089eb12b78af7aaaecd8ed57896677 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 7 Aug 2019 21:27:59 +0200
Subject: Update category according to payment in add overlay

---
 client/src/Component/Select.hs    |  8 +++++-
 client/src/Util/Validation.hs     |  9 +++++--
 client/src/View/Payment.hs        |  1 +
 client/src/View/Payment/Add.hs    | 33 ++++++++++++++++++-----
 client/src/View/Payment/Delete.hs |  9 ++++---
 client/src/View/Payment/Header.hs | 15 +++++++----
 client/src/View/Payment/Table.hs  | 57 ++++++++++++++++++++++++++++-----------
 7 files changed, 97 insertions(+), 35 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 9f671d3..43a8a6e 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -16,6 +16,7 @@ import qualified Common.Msg as Msg
 data (Reflex t) => SelectIn t a b c = SelectIn
   { _selectIn_label        :: Text
   , _selectIn_initialValue :: a
+  , _selectIn_value        :: Event t a
   , _selectIn_values       :: Dynamic t (Map a Text)
   , _selectIn_reset        :: Event t b
   , _selectIn_isValid      :: a -> Bool
@@ -48,11 +49,16 @@ select selectIn = do
 
       let initialValue = _selectIn_initialValue selectIn
 
+      let setValue = R.leftmost
+            [ const initialValue <$> (_selectIn_reset selectIn)
+            , _selectIn_value selectIn
+            ]
+
       value <- R._dropdown_value <$>
         R.dropdown
           initialValue
           (_selectIn_values selectIn)
-          (R.def { R._dropdownConfig_setValue = fmap (const initialValue) (_selectIn_reset selectIn) })
+          (R.def { R._dropdownConfig_setValue = setValue })
 
       errorMessage <- R.holdDyn "" $ R.attachWith
         (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!")
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index e2a3dcb..fc13f36 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,7 +1,8 @@
 module Util.Validation
-  ( fireValidation
+  ( nelError
+  , toMaybe
+  , fireValidation
   , fireMaybe
-  , nelError
   ) where
 
 import           Control.Monad      (join)
@@ -16,6 +17,10 @@ import qualified Reflex.Dom         as R
 nelError :: Validation a b -> Validation (NonEmpty a) b
 nelError = Validation.validation (Failure . NEL.fromList . (:[])) Success
 
+toMaybe :: Validation a b -> Maybe b
+toMaybe (Success s) = Just s
+toMaybe (Failure _) = Nothing
+
 fireValidation
   :: forall t a b c. Reflex t
   => Dynamic t (Maybe (Validation a b))
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f614936..05eedab 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -54,6 +54,7 @@ widget paymentIn = do
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
         , _headerIn_searchPayments = searchPayments
+        , _headerIn_paymentCategories = paymentCategories
         }
 
       table <- Table.widget $ TableIn
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 2970394..d023613 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -4,21 +4,26 @@ module View.Payment.Add
   , AddOut(..)
   ) where
 
+import           Control.Monad             (join)
 import           Control.Monad.IO.Class    (liftIO)
+import qualified Data.List                 as L
 import qualified Data.Map                  as M
 import qualified Data.Maybe                as Maybe
+import           Data.Text                 (Text)
 import qualified Data.Text                 as T
 import qualified Data.Time.Calendar        as Calendar
 import qualified Data.Time.Clock           as Time
 import qualified Data.Validation           as V
-import           Reflex.Dom                (Event, MonadWidget, Reflex)
+import           Reflex.Dom                (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom                as R
 import qualified Text.Read                 as T
 
-import           Common.Model              (Category (..), CreatePayment (..),
+import           Common.Model              (Category (..), CategoryId,
+                                            CreatePayment (..),
                                             CreatedPayment (..), Frequency (..),
                                             Payment (..), PaymentCategory (..))
 import qualified Common.Msg                as Msg
+import qualified Common.Util.Text          as Text
 import qualified Common.Util.Time          as Time
 import qualified Common.Validation.Payment as PaymentValidation
 import           Component                 (ButtonIn (..), InputIn (..),
@@ -31,8 +36,9 @@ import qualified Util.Validation           as ValidationUtil
 import qualified Util.WaitFor              as WaitFor
 
 data AddIn t = AddIn
-  { _addIn_categories :: [Category]
-  , _addIn_cancel     :: Event t ()
+  { _addIn_categories        :: [Category]
+  , _addIn_paymentCategories :: Dynamic t [PaymentCategory]
+  , _addIn_cancel            :: Event t ()
   }
 
 data AddOut t = AddOut
@@ -54,13 +60,13 @@ view addIn = do
               , const "" <$> _addIn_cancel addIn
               ]
 
-        name <- _inputOut_value <$> (Component.input
+        name <- Component.input
           (Component.defaultInputIn
             { _inputIn_label = Msg.get Msg.Payment_Name
             , _inputIn_validation = PaymentValidation.name
             })
           reset
-          validate)
+          validate
 
         cost <- _inputOut_value <$> (Component.input
           (Component.defaultInputIn
@@ -90,15 +96,22 @@ view addIn = do
         frequency <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Frequency
           , _selectIn_initialValue = Punctual
+          , _selectIn_value = R.never
           , _selectIn_values = R.constDyn frequencies
           , _selectIn_reset = reset
           , _selectIn_isValid = const True
           , _selectIn_validate = validate
           })
 
+        let setCategory =
+              R.fmapMaybe id
+                . R.updated
+                $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn)
+
         category <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Category
           , _selectIn_initialValue = -1
+          , _selectIn_value = setCategory
           , _selectIn_values = R.constDyn categories
           , _selectIn_reset = reset
           , _selectIn_isValid = \id -> id /= -1
@@ -106,7 +119,7 @@ view addIn = do
           })
 
         let payment = do
-              n <- name
+              n <- _inputOut_value name
               c <- cost
               d <- date
               cat <- category
@@ -154,3 +167,9 @@ view addIn = do
 
     categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
       (_category_id c, _category_name c)
+
+
+findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
+findCategory paymentName =
+  fmap _paymentCategory_category
+    . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 81c7c57..4aa10f3 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -34,6 +34,11 @@ view deleteIn =
     R.divClass "deleteContent" $ do
 
       (deletedPayment, cancel) <- R.divClass "buttons" $ do
+
+        cancel <- Component._buttonOut_clic <$> (Component.button $
+          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { _buttonIn_class = R.constDyn "undo" })
+
         rec
           confirm <- Component._buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
@@ -50,10 +55,6 @@ view deleteIn =
             (Ajax.delete url)
             confirm
 
-        cancel <- Component._buttonOut_clic <$> (Component.button $
-          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-            { _buttonIn_class = R.constDyn "undo" })
-
         return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
 
       return DeleteOut
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index c49b284..5cc362a 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -20,7 +20,8 @@ import qualified Reflex.Dom             as R
 import           Common.Model           (Category, CreatedPayment (..),
                                          Currency, ExceedingPayer (..),
                                          Frequency (..), Income (..), Init (..),
-                                         Payment (..), User (..))
+                                         Payment (..), PaymentCategory,
+                                         User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -34,8 +35,9 @@ import           View.Payment.Add       (AddIn (..), AddOut (..))
 import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init           :: Init
-  , _headerIn_searchPayments :: Dynamic t [Payment]
+  { _headerIn_init              :: Init
+  , _headerIn_searchPayments    :: Dynamic t [Payment]
+  , _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
   }
 
 data HeaderOut t = HeaderOut
@@ -47,7 +49,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addPayment <- payerAndAdd incomes punctualPayments users categories currency
+    addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency
     let resetSearchName = fmap (const ()) $ addPayment
     (searchName, searchFrequency)  <- searchLine resetSearchName
 
@@ -66,6 +68,7 @@ widget headerIn =
     users = _init_users init
     categories = _init_categories init
     currency = _init_currency init
+    paymentCategories = _headerIn_paymentCategories headerIn
 
 payerAndAdd
   :: forall t m. MonadWidget t m
@@ -73,9 +76,10 @@ payerAndAdd
   -> [Payment]
   -> [User]
   -> [Category]
+  -> Dynamic t [PaymentCategory]
   -> Currency
   -> m (Event t CreatedPayment)
-payerAndAdd incomes payments users categories currency = do
+payerAndAdd incomes payments users categories paymentCategories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
     R.divClass "exceedingPayers" $
@@ -105,6 +109,7 @@ payerAndAdd incomes payments users categories currency = do
             ]
         , _modalIn_content = Add.view $ AddIn
             { _addIn_categories = categories
+            , _addIn_paymentCategories = paymentCategories
             , _addIn_cancel = _modalOut_hide modalOut
             }
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 6432274..cdc4bb3 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -26,7 +26,7 @@ import           View.Payment.Delete (DeleteIn (..), DeleteOut (..))
 import qualified View.Payment.Delete as Delete
 
 import qualified Icon
-import qualified Util.Dom            as Dom
+import qualified Util.Dom            as DomUtil
 
 data TableIn t = TableIn
   { _tableIn_init              :: Init
@@ -57,7 +57,7 @@ widget tableIn = do
       (R.switch . R.current . fmap R.leftmost) <$>
         (R.simpleList paymentRange (paymentRow init paymentCategories))
 
-    Dom.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
+    DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
     return $ TableOut
@@ -79,13 +79,24 @@ getPaymentRange perPage payments currentPage =
     . L.sortOn _payment_date
     $ payments
 
-paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t [PaymentCategory] -> Dynamic t Payment -> m (Event t PaymentId)
+paymentRow
+  :: forall t m. MonadWidget t m
+  => Init
+  -> Dynamic t [PaymentCategory]
+  -> Dynamic t Payment
+  -> m (Event t PaymentId)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
-    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 name" $
+      R.dynText $ fmap _payment_name payment
+
+    R.divClass "cell cost" $
+      R.dynText $ fmap (Format.price (_init_currency init) . _payment_cost) payment
+
+    let user = R.ffor payment (\p ->
+          CM.findUser (_payment_user p) (_init_users init))
+
     R.divClass "cell user" $
       R.dynText $ flip fmap user $ \mbUser -> case mbUser of
         Just u -> _user_name u
@@ -95,13 +106,16 @@ paymentRow init paymentCategories payment =
           p <- payment
           pcs <- paymentCategories
           return $ findCategory (_init_categories init) pcs (_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
@@ -110,15 +124,26 @@ paymentRow init paymentCategories payment =
     R.divClass "cell date" $ do
       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
-    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
-    deletePayment <- R.elDynAttr "div" modifyAttrs $
-      _buttonOut_clic <$> (Component.button $
-        (Component.defaultButtonIn Icon.delete)
-          { _buttonIn_class = R.constDyn "deletePayment" })
+
+    R.divClass "cell button" $
+      R.el "button" Icon.clone
+
+    let isFromCurrentUser =
+          R.ffor
+            payment
+            (\p -> _payment_user p == _init_currentUser init)
+
+    R.divClass "cell button" $
+      DomUtil.divVisibleIf isFromCurrentUser $
+        R.el "button" Icon.edit
+
+    deletePayment <-
+      R.divClass "cell button" $
+        DomUtil.divVisibleIf isFromCurrentUser $
+          _buttonOut_clic <$> (Component.button $
+            (Component.defaultButtonIn Icon.delete)
+              { _buttonIn_class = R.constDyn "deletePayment" })
+
     rec
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = deletePayment
@@ -133,6 +158,6 @@ paymentRow init paymentCategories payment =
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
   paymentCategory <- L.find
-    ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
+    ((== T.formatSearch paymentName) . _paymentCategory_name)
     paymentCategories
   L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
-- 
cgit v1.2.3


From 7c77e52faa71e43324087903c905f9d493b1dfb7 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 8 Aug 2019 21:28:22 +0200
Subject: Finish payment add modal

---
 client/src/Component/Input.hs     | 69 ++++++++++++++++++++++++++-------------
 client/src/Component/Select.hs    | 54 ++++++++++++++++--------------
 client/src/Util/Validation.hs     |  9 +++--
 client/src/View/Payment.hs        |  1 +
 client/src/View/Payment/Add.hs    | 36 +++++++++-----------
 client/src/View/Payment/Header.hs | 34 +++++++++++--------
 6 files changed, 121 insertions(+), 82 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index d679f9b..abdc51c 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -40,7 +40,7 @@ defaultInputIn = InputIn
 
 data InputOut t a = InputOut
   { _inputOut_raw   :: Dynamic t Text
-  , _inputOut_value :: Dynamic t (Maybe (Validation Text a))
+  , _inputOut_value :: Dynamic t (Validation Text a)
   , _inputOut_enter :: Event t ()
   }
 
@@ -64,27 +64,14 @@ input inputIn reset validate = do
 
         value =  R._textInput_value textInput
 
-        containerAttr = R.ffor validatedValue (\v ->
+        containerAttr = R.ffor inputError (\e ->
           M.singleton "class" $ T.intercalate " "
             [ "textInput"
-            , if Maybe.fromMaybe False (ValidationUtil.isFailure <$> v) then "error" else ""
+            , if Maybe.isJust e then "error" else ""
             ])
 
-    -- Clear validation errors after reset
-    delayedReset <- R.delay (0.1 :: NominalDiffTime) reset
-
-    validatedValue <- R.holdDyn Nothing $ R.attachWith
-      (\v (clearValidation, validateEmpty) ->
-        if clearValidation
-           then Nothing
-           else Just (_inputIn_validation inputIn $ (if validateEmpty then "" else v)))
-      (R.current value)
-      (R.leftmost
-        [ const (False, True) <$> resetClic
-        , (\f -> (f, False)) <$> (R.updated . R._textInput_hasFocus $ textInput)
-        , const (False, False) <$> validate
-        , const (True, False) <$> delayedReset
-        ])
+    let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v))
+    inputError <- getInputError valueWithValidation validate
 
     (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
 
@@ -108,7 +95,7 @@ input inputIn reset validate = do
             return R.never
 
       R.divClass "errorMessage" $
-        R.dynText . fmap validationError $ validatedValue
+        R.dynText . fmap (Maybe.fromMaybe "") $ inputError
 
       return (textInput, resetClic)
 
@@ -116,10 +103,46 @@ input inputIn reset validate = do
 
   return $ InputOut
     { _inputOut_raw = value
-    , _inputOut_value = validatedValue
+    , _inputOut_value = fmap snd valueWithValidation
     , _inputOut_enter = enter
     }
 
-validationError :: Maybe (Validation Text a) -> Text
-validationError (Just (Failure e)) = e
-validationError _                  = ""
+getInputError
+  :: forall t m a b c. MonadWidget t m
+  => Dynamic t (Text, Validation Text a)
+  -> Event t c
+  -> m (Dynamic t (Maybe Text))
+getInputError validatedValue validate = do
+  let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue
+      errorEvent = R.updated errorDynamic
+  delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent
+  fmap (fmap fst) $ R.foldDyn
+    (\event (err, hasBeenResetted) ->
+      case event of
+        ModifiedEvent t ->
+          (Nothing, T.null t)
+
+        ValidateEvent e ->
+          (e, False)
+
+        DelayEvent e ->
+          if hasBeenResetted then
+            (Nothing, False)
+          else
+            (e, False)
+    )
+    (Nothing, False)
+    (R.leftmost
+      [ fmap (\(t, _) -> ModifiedEvent t) errorEvent
+      , fmap (\(_, e) -> DelayEvent e) delayedError
+      , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate
+      ])
+
+validationError :: (Validation Text a) -> Maybe Text
+validationError (Failure e) = Just e
+validationError _           = Nothing
+
+data InputEvent
+  = ModifiedEvent Text
+  | DelayEvent (Maybe Text)
+  | ValidateEvent (Maybe Text)
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 43a8a6e..01ed37a 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -4,14 +4,17 @@ module Component.Select
   , select
   ) where
 
-import           Data.Map   (Map)
-import qualified Data.Map   as M
-import           Data.Text  (Text)
-import qualified Data.Text  as T
-import           Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom as R
+import           Data.Map        (Map)
+import qualified Data.Map        as M
+import qualified Data.Maybe      as Maybe
+import           Data.Text       (Text)
+import qualified Data.Text       as T
+import           Data.Validation (Validation (Failure, Success))
+import           Reflex.Dom      (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom      as R
 
-import qualified Common.Msg as Msg
+import qualified Common.Msg      as Msg
+import qualified Util.Validation as ValidationUtil
 
 data (Reflex t) => SelectIn t a b c = SelectIn
   { _selectIn_label        :: Text
@@ -24,25 +27,33 @@ data (Reflex t) => SelectIn t a b c = SelectIn
   }
 
 data SelectOut t a = SelectOut
-  { _selectOut_value :: Dynamic t a
+  { _selectOut_value :: Dynamic t (Validation Text a)
   }
 
 select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a)
 select selectIn = do
   rec
-    let containerAttr = R.ffor hasError (\e ->
+    let containerAttr = R.ffor showedError (\e ->
           M.singleton "class" $ T.intercalate " "
             [ "selectInput"
-            , if e then "error" else ""
+            , if Maybe.isJust e then "error" else ""
             ])
 
-    hasError <- R.holdDyn False $ R.attachWith
-      (\v clearError -> not clearError && not (_selectIn_isValid selectIn v))
-      (R.current value)
-      (R.leftmost
-        [ const False <$> _selectIn_validate selectIn
-        , const True <$> _selectIn_reset selectIn
-        ])
+        validatedValue =
+          R.ffor value (\v ->
+            if _selectIn_isValid selectIn v then
+              Success v
+            else
+              Failure (Msg.get Msg.Form_NonEmpty))
+
+        maybeError =
+          fmap ValidationUtil.maybeError validatedValue
+
+    showedError <- R.holdDyn Nothing $ R.leftmost
+      [ const Nothing <$> _selectIn_reset selectIn
+      , R.updated maybeError
+      , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
+      ]
 
     value <- R.elDynAttr "div" containerAttr $ do
       R.el "label" $ R.text (_selectIn_label selectIn)
@@ -60,16 +71,11 @@ select selectIn = do
           (_selectIn_values selectIn)
           (R.def { R._dropdownConfig_setValue = setValue })
 
-      errorMessage <- R.holdDyn "" $ R.attachWith
-        (\v _ -> if (_selectIn_isValid selectIn) v then "" else "ERROR!")
-        (R.current value)
-        (_selectIn_validate selectIn)
-
       R.divClass "errorMessage" . R.dynText $
-        R.ffor hasError (\e -> if e then Msg.get Msg.Form_NonEmpty else "")
+        R.ffor showedError (Maybe.fromMaybe "")
 
       return value
 
   return SelectOut
-    { _selectOut_value = value
+    { _selectOut_value = validatedValue
     }
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index fc13f36..f9545a4 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -1,6 +1,7 @@
 module Util.Validation
   ( nelError
   , toMaybe
+  , maybeError
   , fireValidation
   , fireMaybe
   ) where
@@ -21,14 +22,18 @@ toMaybe :: Validation a b -> Maybe b
 toMaybe (Success s) = Just s
 toMaybe (Failure _) = Nothing
 
+maybeError :: Validation a b -> Maybe a
+maybeError (Success _) = Nothing
+maybeError (Failure e) = Just e
+
 fireValidation
   :: forall t a b c. Reflex t
-  => Dynamic t (Maybe (Validation a b))
+  => Dynamic t (Validation a b)
   -> Event t c
   -> Event t b
 fireValidation value validate =
   R.fmapMaybe
-    (join . fmap (Validation.validation (const Nothing) Just))
+    (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
 
 fireMaybe
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 05eedab..ae20079 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -53,6 +53,7 @@ widget paymentIn = do
 
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
+        , _headerIn_payments = payments
         , _headerIn_searchPayments = searchPayments
         , _headerIn_paymentCategories = paymentCategories
         }
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index d023613..e0772f7 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -66,7 +66,7 @@ view addIn = do
             , _inputIn_validation = PaymentValidation.name
             })
           reset
-          validate
+          confirm
 
         cost <- _inputOut_value <$> (Component.input
           (Component.defaultInputIn
@@ -74,7 +74,7 @@ view addIn = do
             , _inputIn_validation = PaymentValidation.cost
             })
           reset
-          validate)
+          confirm)
 
         now <- liftIO Time.getCurrentTime
 
@@ -91,7 +91,7 @@ view addIn = do
             , _inputIn_validation = PaymentValidation.date
             })
           (const currentDay <$> reset)
-          validate)
+          confirm)
 
         frequency <- _selectOut_value <$> (Component.select $ SelectIn
           { _selectIn_label = Msg.get Msg.Payment_Frequency
@@ -100,7 +100,7 @@ view addIn = do
           , _selectIn_values = R.constDyn frequencies
           , _selectIn_reset = reset
           , _selectIn_isValid = const True
-          , _selectIn_validate = validate
+          , _selectIn_validate = confirm
           })
 
         let setCategory =
@@ -115,7 +115,7 @@ view addIn = do
           , _selectIn_values = R.constDyn categories
           , _selectIn_reset = reset
           , _selectIn_isValid = \id -> id /= -1
-          , _selectIn_validate = validate
+          , _selectIn_validate = confirm
           })
 
         let payment = do
@@ -124,24 +124,20 @@ view addIn = do
               d <- date
               cat <- category
               f <- frequency
-              pure $ do
-                n' <- n
-                c' <- c
-                d' <- d
-                pure $ CreatePayment
-                  <$> ValidationUtil.nelError n'
-                  <*> ValidationUtil.nelError c'
-                  <*> ValidationUtil.nelError d'
-                  <*> ValidationUtil.nelError (V.Success cat)
-                  <*> ValidationUtil.nelError (V.Success f)
-
-        (addPayment, cancel, validate) <- R.divClass "buttons" $ do
+              return (CreatePayment
+                <$> ValidationUtil.nelError n
+                <*> ValidationUtil.nelError c
+                <*> ValidationUtil.nelError d
+                <*> ValidationUtil.nelError cat
+                <*> ValidationUtil.nelError f)
+
+        (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
           rec
             cancel <- Component._buttonOut_clic <$> (Component.button $
               (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
                 { _buttonIn_class = R.constDyn "undo" })
 
-            validate <- Component._buttonOut_clic <$> (Component.button $
+            confirm <- Component._buttonOut_clic <$> (Component.button $
               (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
                 { _buttonIn_class = R.constDyn "confirm"
                 , _buttonIn_waiting = waiting
@@ -150,9 +146,9 @@ view addIn = do
 
             (addPayment, waiting) <- WaitFor.waitFor
               (Ajax.postJson "/payment")
-              (ValidationUtil.fireValidation payment validate)
+              (ValidationUtil.fireValidation payment confirm)
 
-          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, validate)
+          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
 
       return AddOut
         { _addOut_cancel = cancel
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 5cc362a..73517f0 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -36,6 +36,7 @@ import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
   { _headerIn_init              :: Init
+  , _headerIn_payments          :: Dynamic t [Payment]
   , _headerIn_searchPayments    :: Dynamic t [Payment]
   , _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
   }
@@ -49,7 +50,7 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addPayment <- payerAndAdd incomes punctualPayments users categories paymentCategories currency
+    addPayment <- payerAndAdd incomes payments users categories paymentCategories currency
     let resetSearchName = fmap (const ()) $ addPayment
     (searchName, searchFrequency)  <- searchLine resetSearchName
 
@@ -64,7 +65,7 @@ widget headerIn =
     init = _headerIn_init headerIn
     incomes = _init_incomes init
     initPayments = _init_payments init
-    punctualPayments = filter ((==) Punctual . _payment_frequency) initPayments
+    payments = _headerIn_payments headerIn
     users = _init_users init
     categories = _init_categories init
     currency = _init_currency init
@@ -73,7 +74,7 @@ widget headerIn =
 payerAndAdd
   :: forall t m. MonadWidget t m
   => [Income]
-  -> [Payment]
+  -> Dynamic t [Payment]
   -> [User]
   -> [Category]
   -> Dynamic t [PaymentCategory]
@@ -82,17 +83,23 @@ payerAndAdd
 payerAndAdd incomes payments users categories paymentCategories currency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
+
+    let exceedingPayers =
+          R.ffor payments $ \ps ->
+            CM.getExceedingPayers time users incomes $
+              filter ((==) Punctual . _payment_frequency) ps
+
     R.divClass "exceedingPayers" $
-      forM_
-        (CM.getExceedingPayers time users incomes payments)
-        (\p ->
-          R.elClass "span" "exceedingPayer" $ do
-            R.elClass "span" "userName" $
-              R.text . fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId p) users
-            R.elClass "span" "amount" $ do
-              R.text "+ "
-              R.text . Format.price currency $ _exceedingPayer_amount p
-        )
+      R.simpleList exceedingPayers $ \exceedingPayer ->
+        R.elClass "span" "exceedingPayer" $ do
+          R.elClass "span" "userName" $
+            R.dynText . R.ffor exceedingPayer $ \ep ->
+              fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
+          R.elClass "span" "amount" $ do
+            R.text "+ "
+            R.dynText . R.ffor exceedingPayer $ \ep ->
+              Format.price currency $ _exceedingPayer_amount ep
+
     addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
       { _buttonIn_class = R.constDyn "addPayment"
       , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
@@ -100,6 +107,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do
       , _buttonIn_tabIndex = Nothing
       , _buttonIn_submit = False
       })
+
     rec
       modalOut <- Component.modal $ ModalIn
         { _modalIn_show    = addPaymentClic
-- 
cgit v1.2.3


From 3943c50d5320f7137bd5acec4485dd56a2aa52b3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 09:59:22 +0200
Subject: Debounce payments search

---
 client/src/View/Payment.hs | 13 ++++++++++---
 1 file changed, 10 insertions(+), 3 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index ae20079..915cc18 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -6,6 +6,7 @@ module View.Payment
 
 import           Data.Text           (Text)
 import qualified Data.Text           as T
+import           Data.Time.Clock     (NominalDiffTime)
 import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
@@ -47,10 +48,16 @@ widget paymentIn = do
 
       let searchPayments =
             getSearchPayments
-              (_headerOut_searchName header)
+              debouncedSearchName
               (_headerOut_searchFrequency header)
               payments
 
+      debouncedSearchNameEvt <-
+        R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header)
+
+      debouncedSearchName <-
+        R.holdDyn "" debouncedSearchNameEvt
+
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
         , _headerIn_payments = payments
@@ -70,8 +77,8 @@ widget paymentIn = do
         { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
-            [ fmap (const ()) . R.updated . _headerOut_searchName $ header
-            , fmap (const ()) . _headerOut_addPayment $ header
+            [ const () <$> debouncedSearchNameEvt
+            , const () <$> _headerOut_addPayment header
             ]
         }
 
-- 
cgit v1.2.3


From fb8f0fe577e28dae69903413b761da50586e0099 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 14:53:41 +0200
Subject: Remove payment category if unused after a payment is deleted

---
 client/src/View/Payment.hs        | 49 +++++++++++++++++++++++++++------------
 client/src/View/Payment/Add.hs    |  3 +--
 client/src/View/Payment/Delete.hs | 35 ++++++++++++++--------------
 client/src/View/Payment/Table.hs  | 12 ++++------
 4 files changed, 58 insertions(+), 41 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 915cc18..46ab642 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -45,18 +45,14 @@ widget paymentIn = do
       paymentCategories <- getPaymentCategories
         (_init_paymentCategories init)
         (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
+        payments
+        (_tableOut_deletePayment table)
 
-      let searchPayments =
-            getSearchPayments
-              debouncedSearchName
-              (_headerOut_searchFrequency header)
-              payments
-
-      debouncedSearchNameEvt <-
-        R.debounce (0.5 :: NominalDiffTime) (R.updated $ _headerOut_searchName header)
+      (searchNameEvent, searchName) <-
+        debounceSearchName (_headerOut_searchName header)
 
-      debouncedSearchName <-
-        R.holdDyn "" debouncedSearchNameEvt
+      let searchPayments =
+            getSearchPayments searchName (_headerOut_searchFrequency header) payments
 
       header <- Header.widget $ HeaderIn
         { _headerIn_init = init
@@ -77,34 +73,57 @@ widget paymentIn = do
         { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
-            [ const () <$> debouncedSearchNameEvt
+            [ const () <$> searchNameEvent
             , const () <$> _headerOut_addPayment header
             ]
         }
 
     pure $ PaymentOut {}
 
+debounceSearchName
+  :: forall t m. MonadWidget t m
+  => Dynamic t Text
+  -> m (Event t Text, Dynamic t Text)
+debounceSearchName searchName = do
+  event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
+  dynamic <- R.holdDyn "" event
+  return (event, dynamic)
+
 getPayments
   :: forall t m. MonadWidget t m
   => [Payment]
   -> Event t Payment
-  -> Event t PaymentId
+  -> Event t Payment
   -> m (Dynamic t [Payment])
 getPayments initPayments addPayment deletePayment =
   R.foldDyn id initPayments $ R.leftmost
     [ (:) <$> addPayment
-    , flip fmap deletePayment (\paymentId -> filter ((/= paymentId) . _payment_id))
+    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
     ]
 
 getPaymentCategories
   :: forall t m. MonadWidget t m
   => [PaymentCategory]
-  -> Event t PaymentCategory
+  -> Event t PaymentCategory  -- add payment category
+  -> Dynamic t [Payment]      -- payments
+  -> Event t Payment          -- delete payment
   -> m (Dynamic t [PaymentCategory])
-getPaymentCategories initPaymentCategories addPaymentCategory =
+getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment =
   R.foldDyn id initPaymentCategories $ R.leftmost
     [ (:) <$> addPaymentCategory
+    , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
     ]
+  where
+    deletePaymentName =
+      R.attachWithMaybe
+        (\ps p ->
+          if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
+            Nothing
+          else
+            Just (_payment_name p))
+        (R.current payments)
+        deletePayment
+    lowerName = T.toLower . _payment_name
 
 getSearchPayments
   :: forall t. Reflex t
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index e0772f7..bd10e5a 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -23,7 +23,6 @@ import           Common.Model              (Category (..), CategoryId,
                                             CreatedPayment (..), Frequency (..),
                                             Payment (..), PaymentCategory (..))
 import qualified Common.Msg                as Msg
-import qualified Common.Util.Text          as Text
 import qualified Common.Util.Time          as Time
 import qualified Common.Validation.Payment as PaymentValidation
 import           Component                 (ButtonIn (..), InputIn (..),
@@ -168,4 +167,4 @@ view addIn = do
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
 findCategory paymentName =
   fmap _paymentCategory_category
-    . L.find ((==) (Text.formatSearch paymentName) . _paymentCategory_name)
+    . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 4aa10f3..65ce660 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -4,26 +4,26 @@ module View.Payment.Delete
   , DeleteOut(..)
   ) where
 
-import           Data.Text            (Text)
-import qualified Data.Text            as T
-import           Reflex.Dom           (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom           as R
-
-import           Common.Model.Payment (PaymentId)
-import qualified Common.Msg           as Msg
-import           Component            (ButtonIn (..), ButtonOut (..))
-import qualified Component            as Component
-import qualified Util.Ajax            as Ajax
-import qualified Util.Either          as EitherUtil
-import qualified Util.WaitFor         as WaitFor
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (Payment (..))
+import qualified Common.Msg   as Msg
+import           Component    (ButtonIn (..), ButtonOut (..))
+import qualified Component    as Component
+import qualified Util.Ajax    as Ajax
+import qualified Util.Either  as EitherUtil
+import qualified Util.WaitFor as WaitFor
 
 data DeleteIn t = DeleteIn
-  { _deleteIn_id :: Dynamic t PaymentId
+  { _deleteIn_payment :: Dynamic t Payment
   }
 
 data DeleteOut t = DeleteOut
   { _deleteOut_cancel   :: Event t ()
-  , _deleteOut_validate :: Event t PaymentId
+  , _deleteOut_validate :: Event t Payment
   }
 
 view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
@@ -47,8 +47,9 @@ view deleteIn =
               , _buttonIn_waiting = waiting
               })
 
-          let url = flip fmap (_deleteIn_id deleteIn) (\id ->
-                  T.concat ["/payment/", T.pack . show $ id]
+          let url =
+                R.ffor (_deleteIn_payment deleteIn) (\id ->
+                  T.concat ["/payment/", T.pack . show $ _payment_id id]
                 )
 
           (result, waiting) <- WaitFor.waitFor
@@ -59,5 +60,5 @@ view deleteIn =
 
       return DeleteOut
         { _deleteOut_cancel = cancel
-        , _deleteOut_validate = R.tag (R.current $ _deleteIn_id deleteIn) deletedPayment
+        , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment
         }
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index cdc4bb3..b09f30f 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,11 +13,9 @@ import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
 import           Common.Model        (Category (..), Init (..), Payment (..),
-                                      PaymentCategory (..), PaymentId,
-                                      User (..))
+                                      PaymentCategory (..), User (..))
 import qualified Common.Model        as CM
 import qualified Common.Msg          as Msg
-import qualified Common.Util.Text    as T
 import qualified Common.View.Format  as Format
 import           Component           (ButtonIn (..), ButtonOut (..),
                                       ModalIn (..), ModalOut (..))
@@ -37,7 +35,7 @@ data TableIn t = TableIn
   }
 
 data TableOut t = TableOut
-  { _tableOut_deletePayment :: Event t PaymentId
+  { _tableOut_deletePayment :: Event t Payment
   }
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
@@ -84,7 +82,7 @@ paymentRow
   => Init
   -> Dynamic t [PaymentCategory]
   -> Dynamic t Payment
-  -> m (Event t PaymentId)
+  -> m (Event t Payment)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
 
@@ -151,13 +149,13 @@ paymentRow init paymentCategories payment =
             [ _deleteOut_cancel . _modalOut_content $ modalOut
             , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut
             ]
-        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_id = fmap _payment_id payment })
+        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment })
         }
     return (_deleteOut_validate . _modalOut_content $ modalOut)
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
   paymentCategory <- L.find
-    ((== T.formatSearch paymentName) . _paymentCategory_name)
+    ((== T.toLower paymentName) . _paymentCategory_name)
     paymentCategories
   L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
-- 
cgit v1.2.3


From 234b5b29361734656dc780148309962f932d9907 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 15:07:11 +0200
Subject: Use select component in payment search line

---
 client/src/Component/Select.hs    |  6 ++++--
 client/src/View/Payment/Header.hs | 15 ++++++++++++---
 2 files changed, 16 insertions(+), 5 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 01ed37a..cf62f26 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -27,7 +27,8 @@ data (Reflex t) => SelectIn t a b c = SelectIn
   }
 
 data SelectOut t a = SelectOut
-  { _selectOut_value :: Dynamic t (Validation Text a)
+  { _selectOut_raw   :: Dynamic t a
+  , _selectOut_value :: Dynamic t (Validation Text a)
   }
 
 select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a)
@@ -77,5 +78,6 @@ select selectIn = do
       return value
 
   return SelectOut
-    { _selectOut_value = validatedValue
+    { _selectOut_raw = value
+    , _selectOut_value = validatedValue
     }
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 73517f0..7a85493 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -28,7 +28,8 @@ import qualified Common.View.Format     as Format
 
 import           Component              (ButtonIn (..), ButtonOut (..),
                                          InputIn (..), InputOut (..),
-                                         ModalIn (..), ModalOut (..))
+                                         ModalIn (..), ModalOut (..),
+                                         SelectIn (..), SelectOut (..))
 import qualified Component              as Component
 import qualified Util.List              as L
 import           View.Payment.Add       (AddIn (..), AddOut (..))
@@ -140,8 +141,16 @@ searchLine reset = do
           , (Monthly, Msg.get Msg.Payment_MonthlyMale)
           ]
 
-    searchFrequency <- R._dropdown_value <$>
-      R.dropdown Punctual (R.constDyn frequencies) R.def
+    searchFrequency <- _selectOut_raw <$> (Component.select $
+      SelectIn
+        { _selectIn_label        = ""
+        , _selectIn_initialValue = Punctual
+        , _selectIn_value        = R.never
+        , _selectIn_values       = R.constDyn frequencies
+        , _selectIn_reset        = R.never
+        , _selectIn_isValid      = const True
+        , _selectIn_validate     = R.never
+        })
 
     return (searchName, searchFrequency)
 
-- 
cgit v1.2.3


From c5c54722f4736108c8418c9865f81f05a6db560d Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 15:29:56 +0200
Subject: Fix payment add frequency to the one selected in the page

---
 client/src/View/Payment/Add.hs    | 15 +++------------
 client/src/View/Payment/Header.hs | 23 +++++++++++++++++------
 2 files changed, 20 insertions(+), 18 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index bd10e5a..d2d2dc4 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -37,6 +37,7 @@ import qualified Util.WaitFor              as WaitFor
 data AddIn t = AddIn
   { _addIn_categories        :: [Category]
   , _addIn_paymentCategories :: Dynamic t [PaymentCategory]
+  , _addIn_frequency         :: Dynamic t Frequency
   , _addIn_cancel            :: Event t ()
   }
 
@@ -92,16 +93,6 @@ view addIn = do
           (const currentDay <$> reset)
           confirm)
 
-        frequency <- _selectOut_value <$> (Component.select $ SelectIn
-          { _selectIn_label = Msg.get Msg.Payment_Frequency
-          , _selectIn_initialValue = Punctual
-          , _selectIn_value = R.never
-          , _selectIn_values = R.constDyn frequencies
-          , _selectIn_reset = reset
-          , _selectIn_isValid = const True
-          , _selectIn_validate = confirm
-          })
-
         let setCategory =
               R.fmapMaybe id
                 . R.updated
@@ -122,13 +113,13 @@ view addIn = do
               c <- cost
               d <- date
               cat <- category
-              f <- frequency
+              f <- _addIn_frequency addIn
               return (CreatePayment
                 <$> ValidationUtil.nelError n
                 <*> ValidationUtil.nelError c
                 <*> ValidationUtil.nelError d
                 <*> ValidationUtil.nelError cat
-                <*> ValidationUtil.nelError f)
+                <*> V.Success f)
 
         (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
           rec
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 7a85493..fa21731 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -51,11 +51,20 @@ data HeaderOut t = HeaderOut
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 widget headerIn =
   R.divClass "header" $ do
-    addPayment <- payerAndAdd incomes payments users categories paymentCategories currency
-    let resetSearchName = fmap (const ()) $ addPayment
-    (searchName, searchFrequency)  <- searchLine resetSearchName
-
-    infos (_headerIn_searchPayments headerIn) users currency
+    rec
+      addPayment <-
+        payerAndAdd
+          incomes
+          payments
+          users
+          categories
+          paymentCategories
+          currency
+          searchFrequency
+      let resetSearchName = fmap (const ()) $ addPayment
+      (searchName, searchFrequency)  <- searchLine resetSearchName
+
+      infos (_headerIn_searchPayments headerIn) users currency
 
     return $ HeaderOut
       { _headerOut_searchName = searchName
@@ -80,8 +89,9 @@ payerAndAdd
   -> [Category]
   -> Dynamic t [PaymentCategory]
   -> Currency
+  -> Dynamic t Frequency
   -> m (Event t CreatedPayment)
-payerAndAdd incomes payments users categories paymentCategories currency = do
+payerAndAdd incomes payments users categories paymentCategories currency frequency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
 
@@ -119,6 +129,7 @@ payerAndAdd incomes payments users categories paymentCategories currency = do
         , _modalIn_content = Add.view $ AddIn
             { _addIn_categories = categories
             , _addIn_paymentCategories = paymentCategories
+            , _addIn_frequency = frequency
             , _addIn_cancel = _modalOut_hide modalOut
             }
         }
-- 
cgit v1.2.3


From c542424b7b41c78a170763f6996c12f56b359860 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 10 Aug 2019 21:31:27 +0200
Subject: Add smooth transitions to modal show and hide

---
 client/src/Component/Modal.hs     | 79 ++++++++++++++++++++++++++-------------
 client/src/Component/Select.hs    |  4 +-
 client/src/Util/WaitFor.hs        |  2 +-
 client/src/View/Payment.hs        |  4 +-
 client/src/View/Payment/Add.hs    |  8 ++--
 client/src/View/Payment/Header.hs |  2 +-
 client/src/View/SignIn.hs         |  4 +-
 7 files changed, 64 insertions(+), 39 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index d7943a9..fac417e 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -8,6 +8,8 @@ import           Control.Monad     (void)
 import qualified Data.Map          as M
 import qualified Data.Map.Lazy     as LM
 import           Data.Text         (Text)
+import qualified Data.Text         as T
+import           Data.Time.Clock   (NominalDiffTime)
 import qualified GHCJS.DOM.Element as Element
 import qualified GHCJS.DOM.Node    as Node
 import           JSDOM.Types       (JSString)
@@ -31,52 +33,75 @@ data ModalOut t a = ModalOut
 modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a)
 modal modalIn = do
   rec
-    let showEvent = R.leftmost
-          [ True <$ _modalIn_show modalIn
-          , False <$ _modalIn_hide modalIn
-          , False <$ curtainClick
-          ]
+    let show = Show <$ (_modalIn_show modalIn)
 
-    showModal <- R.holdDyn False showEvent
+        startHiding =
+          R.attachWithMaybe
+            (\a _ -> if a then Just StartHiding else Nothing)
+            (R.current canBeHidden)
+            (R.leftmost [ _modalIn_hide modalIn, curtainClick ])
+
+    canBeHidden <-
+      R.holdDyn True $ R.leftmost
+        [ False <$ startHiding
+        , True <$ endHiding
+        ]
+
+    endHiding <-
+      R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding)
+
+    let action =
+          R.leftmost [ show, startHiding, endHiding ]
+
+    modalClass <-
+      R.holdDyn "" (fmap getModalClass action)
 
     (elem, (curtainClick, content)) <-
-      R.buildElement "div" (getAttributes <$> showModal) $ do
-        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
-        cont <- R.divClass "modalContent" $ _modalIn_content modalIn
-        return (R.domEvent R.Click curtain, cont)
+      R.buildElement "div" (fmap getAttributes modalClass) $ do
+        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
+        content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn
+        return (R.domEvent R.Click curtain, content)
 
-  performShowEffects showEvent elem
+  performShowEffects action elem
 
   return $ ModalOut
     { _modalOut_content = content
     , _modalOut_hide = curtainClick
     }
 
-getAttributes :: Bool -> LM.Map Text Text
-getAttributes show =
-  M.fromList $
-    [ ("style", if show then "display:block" else "display:none")
-    , ("class", "modal")
-    ]
+getAttributes :: Text -> LM.Map Text Text
+getAttributes modalClass =
+  M.singleton "class" $
+    T.intercalate " " [ "g-Modal", modalClass]
 
 performShowEffects
   :: forall t m a. MonadWidget t m
-  => Event t Bool
+  => Event t Action
   -> Element.Element
   -> m ()
 performShowEffects showEvent elem = do
   body <- Dom.getBody
 
   let showEffects =
-        flip fmap showEvent (\show -> do
-          if show then
-            do
-              Node.appendChild body elem
-              Element.setClassName body ("modal" :: JSString)
-          else
-            do
-              Node.removeChild body elem
-              Element.setClassName body ("" :: JSString)
+        flip fmap showEvent (\case
+          Show -> do
+            Node.appendChild body elem
+            Element.setClassName body ("g-Body--Modal" :: JSString)
+          StartHiding ->
+            return ()
+          EndHiding -> do
+            Node.removeChild body elem
+            Element.setClassName body ("" :: JSString)
         )
 
   R.performEvent_ $ void `fmap` showEffects
+
+data Action
+  = Show
+  | StartHiding
+  | EndHiding
+
+getModalClass :: Action -> Text
+getModalClass Show        = "g-Modal--Show"
+getModalClass StartHiding = "g-Modal--Hiding"
+getModalClass _           = ""
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index cf62f26..9a37afc 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -51,7 +51,7 @@ select selectIn = do
           fmap ValidationUtil.maybeError validatedValue
 
     showedError <- R.holdDyn Nothing $ R.leftmost
-      [ const Nothing <$> _selectIn_reset selectIn
+      [ Nothing <$ _selectIn_reset selectIn
       , R.updated maybeError
       , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
       ]
@@ -62,7 +62,7 @@ select selectIn = do
       let initialValue = _selectIn_initialValue selectIn
 
       let setValue = R.leftmost
-            [ const initialValue <$> (_selectIn_reset selectIn)
+            [ initialValue <$ (_selectIn_reset selectIn)
             , _selectIn_value selectIn
             ]
 
diff --git a/client/src/Util/WaitFor.hs b/client/src/Util/WaitFor.hs
index 02edff5..fe7b733 100644
--- a/client/src/Util/WaitFor.hs
+++ b/client/src/Util/WaitFor.hs
@@ -13,5 +13,5 @@ waitFor
   -> m (Event t b, Event t Bool)
 waitFor op input = do
   result <- op input >>= R.debounce (0.5 :: NominalDiffTime)
-  let waiting = R.leftmost [ const True <$> input , const False <$> result ]
+  let waiting = R.leftmost [ True <$ input , False <$ result ]
   return (result, waiting)
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index 46ab642..f363b06 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -73,8 +73,8 @@ widget paymentIn = do
         { _pagesIn_total = length <$> searchPayments
         , _pagesIn_perPage = paymentsPerPage
         , _pagesIn_reset = R.leftmost $
-            [ const () <$> searchNameEvent
-            , const () <$> _headerOut_addPayment header
+            [ () <$ searchNameEvent
+            , () <$ _headerOut_addPayment header
             ]
         }
 
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index d2d2dc4..69e29a7 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -55,9 +55,9 @@ view addIn = do
     R.divClass "addContent" $ do
       rec
         let reset = R.leftmost
-              [ const "" <$> cancel
-              , const "" <$> addPayment
-              , const "" <$> _addIn_cancel addIn
+              [ "" <$ cancel
+              , "" <$ addPayment
+              , "" <$ _addIn_cancel addIn
               ]
 
         name <- Component.input
@@ -90,7 +90,7 @@ view addIn = do
             , _inputIn_hasResetButton = False
             , _inputIn_validation = PaymentValidation.date
             })
-          (const currentDay <$> reset)
+          (currentDay <$ reset)
           confirm)
 
         let setCategory =
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index fa21731..1bdee8d 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -144,7 +144,7 @@ searchLine reset = do
   R.divClass "searchLine" $ do
     searchName <- _inputOut_raw <$> (Component.input
       ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
-      (const "" <$> reset)
+      ("" <$ reset)
       R.never)
 
     let frequencies = M.fromList
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 6fbf6d6..f8b985f 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -37,7 +37,7 @@ view signInMessage =
             { _inputIn_label = Msg.get Msg.SignIn_EmailLabel
             , _inputIn_validation = SignInValidation.email
             })
-          (const "" <$> R.ffilter Either.isRight signInResult)
+          ("" <$ R.ffilter Either.isRight signInResult)
           validate)
 
         validate <- _buttonOut_clic <$> (Component.button $
@@ -52,7 +52,7 @@ view signInMessage =
         (signInResult, waiting) <- WaitFor.waitFor
           (Ajax.postJson "/askSignIn")
           (ValidationUtil.fireMaybe
-            ((\f -> const f <$> SignInValidation.signIn f) <$> form)
+            ((\f -> f <$ SignInValidation.signIn f) <$> form)
             validate)
 
       showSignInResult signInMessage signInResult
-- 
cgit v1.2.3


From 2d79ab0e0a11f55255fc21a5dfab1598d3beeba3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 11 Aug 2019 22:40:09 +0200
Subject: Add payment clone

---
 client/src/Component/Modal.hs     |  63 +++++++------
 client/src/Util/Dom.hs            |  45 ---------
 client/src/Util/Reflex.hs         |  52 +++++++++++
 client/src/View/Payment.hs        |  14 ++-
 client/src/View/Payment/Add.hs    | 187 ++++++++------------------------------
 client/src/View/Payment/Clone.hs  |  60 ++++++++++++
 client/src/View/Payment/Delete.hs |  57 ++++++------
 client/src/View/Payment/Edit.hs   |  55 +++++++++++
 client/src/View/Payment/Form.hs   | 165 +++++++++++++++++++++++++++++++++
 client/src/View/Payment/Header.hs |  39 +++-----
 client/src/View/Payment/Pages.hs  |  14 +--
 client/src/View/Payment/Table.hs  | 109 ++++++++++++++++------
 12 files changed, 544 insertions(+), 316 deletions(-)
 delete mode 100644 client/src/Util/Dom.hs
 create mode 100644 client/src/Util/Reflex.hs
 create mode 100644 client/src/View/Payment/Clone.hs
 create mode 100644 client/src/View/Payment/Edit.hs
 create mode 100644 client/src/View/Payment/Form.hs

(limited to 'client/src')

diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index fac417e..96c2679 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,7 +1,7 @@
 module Component.Modal
-  ( ModalIn(..)
-  , ModalOut(..)
-  , modal
+  ( Input(..)
+  , Content
+  , view
   ) where
 
 import           Control.Monad     (void)
@@ -17,29 +17,26 @@ import           Reflex.Dom        (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom        as R
 import qualified Reflex.Dom.Class  as R
 
-import qualified Util.Dom          as Dom
+import qualified Util.Reflex       as ReflexUtil
 
-data ModalIn t m a = ModalIn
-  { _modalIn_show    :: Event t ()
-  , _modalIn_hide    :: Event t ()
-  , _modalIn_content :: m a
-  }
+-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
+type Content t m a = Event t () -> m (Event t (), Event t a)
 
-data ModalOut t a = ModalOut
-  { _modalOut_content :: a
-  , _modalOut_hide    :: Event t ()
+data Input t m a = Input
+  { _input_show    :: Event t ()
+  , _input_content :: Content t m a
   }
 
-modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a)
-modal modalIn = do
+view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a)
+view input = do
   rec
-    let show = Show <$ (_modalIn_show modalIn)
+    let show = Show <$ (_input_show input)
 
         startHiding =
           R.attachWithMaybe
             (\a _ -> if a then Just StartHiding else Nothing)
             (R.current canBeHidden)
-            (R.leftmost [ _modalIn_hide modalIn, curtainClick ])
+            (R.leftmost [ hide, curtainClick ])
 
     canBeHidden <-
       R.holdDyn True $ R.leftmost
@@ -56,18 +53,25 @@ modal modalIn = do
     modalClass <-
       R.holdDyn "" (fmap getModalClass action)
 
-    (elem, (curtainClick, content)) <-
-      R.buildElement "div" (fmap getAttributes modalClass) $ do
-        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
-        content <- R.divClass "g-Modal__Content" $ _modalIn_content modalIn
-        return (R.domEvent R.Click curtain, content)
+    (elem, dyn) <-
+      R.buildElement "div" (getAttributes <$> modalClass) $
+        ReflexUtil.visibleIfEvent
+          (isVisible <$> action)
+          (R.blank >> return (R.never, R.never, R.never))
+          (do
+            (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
+            let curtainClick = R.domEvent R.Click curtain
+            (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick)
+            return (curtainClick, hide, content))
+
 
-  performShowEffects action elem
+    performShowEffects action elem
 
-  return $ ModalOut
-    { _modalOut_content = content
-    , _modalOut_hide = curtainClick
-    }
+    let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn
+    let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn
+    let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
+
+  return content
 
 getAttributes :: Text -> LM.Map Text Text
 getAttributes modalClass =
@@ -80,7 +84,7 @@ performShowEffects
   -> Element.Element
   -> m ()
 performShowEffects showEvent elem = do
-  body <- Dom.getBody
+  body <- ReflexUtil.getBody
 
   let showEffects =
         flip fmap showEvent (\case
@@ -105,3 +109,8 @@ getModalClass :: Action -> Text
 getModalClass Show        = "g-Modal--Show"
 getModalClass StartHiding = "g-Modal--Hiding"
 getModalClass _           = ""
+
+isVisible :: Action -> Bool
+isVisible Show        = True
+isVisible StartHiding = True
+isVisible EndHiding   = False
diff --git a/client/src/Util/Dom.hs b/client/src/Util/Dom.hs
deleted file mode 100644
index 55b8521..0000000
--- a/client/src/Util/Dom.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Util.Dom
-  ( divIfDyn
-  , divIfEvent
-  , divVisibleIf
-  , divClassVisibleIf
-  , getBody
-  ) where
-
-import qualified Data.Map                 as M
-import           Data.Text                (Text)
-import qualified GHCJS.DOM                as Dom
-import qualified GHCJS.DOM.Document       as Document
-import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
-import           GHCJS.DOM.Types          (Element)
-import           Reflex.Dom               (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom               as R
-
-divIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Dynamic t a)
-divIfDyn cond = divIfEvent (R.updated cond)
-
-divIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
-divIfEvent cond empty content =
-  R.widgetHold empty (flip fmap cond (\show ->
-    if show
-      then
-        content
-      else
-        empty))
-
-divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
-divVisibleIf cond content = divClassVisibleIf cond "" content
-
-divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
-divClassVisibleIf cond className content =
-  R.elDynAttr
-    "div"
-    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
-    content
-
-getBody :: forall t m. MonadWidget t m => m Element
-getBody = do
-  document <- Dom.currentDocumentUnchecked
-  nodelist <- Document.getElementsByTagName document ("body" :: String)
-  Just body <- nodelist `HTMLCollection.item` 0
-  return body
diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
new file mode 100644
index 0000000..c14feeb
--- /dev/null
+++ b/client/src/Util/Reflex.hs
@@ -0,0 +1,52 @@
+module Util.Reflex
+  ( visibleIfDyn
+  , visibleIfEvent
+  , divVisibleIf
+  , divClassVisibleIf
+  , flatten
+  , getBody
+  ) where
+
+import qualified Data.Map                 as M
+import           Data.Text                (Text)
+import qualified GHCJS.DOM                as Dom
+import qualified GHCJS.DOM.Document       as Document
+import qualified GHCJS.DOM.HTMLCollection as HTMLCollection
+import           GHCJS.DOM.Types          (Element)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+visibleIfDyn :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a -> m (Event t a)
+visibleIfDyn cond empty content =
+  R.dyn $ R.ffor cond $ \case
+    True -> content
+    False -> empty
+
+visibleIfEvent :: forall t m a. MonadWidget t m => Event t Bool -> m a -> m a -> m (Dynamic t a)
+visibleIfEvent cond empty content =
+  R.widgetHold empty $
+    R.ffor cond $ \case
+      True -> content
+      False -> empty
+
+divVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> m a -> m a
+divVisibleIf cond content = divClassVisibleIf cond "" content
+
+divClassVisibleIf :: forall t m a. MonadWidget t m => Dynamic t Bool -> Text -> m a -> m a
+divClassVisibleIf cond className content =
+  R.elDynAttr
+    "div"
+    (fmap (\c -> (M.singleton "class" className) `M.union` if c then M.empty else M.singleton "style" "display:none") cond)
+    content
+
+flatten :: forall t m a. MonadWidget t m => Event t (Event t a) -> m (Event t a)
+flatten e = do
+  dyn <- R.holdDyn R.never e
+  return $ R.switchDyn dyn
+
+getBody :: forall t m. MonadWidget t m => m Element
+getBody = do
+  document <- Dom.currentDocumentUnchecked
+  nodelist <- Document.getElementsByTagName document ("body" :: String)
+  Just body <- nodelist `HTMLCollection.item` 0
+  return body
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f363b06..ab83447 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -11,9 +11,9 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (CreatedPayment (..), Frequency, Init (..),
-                                      Payment (..), PaymentCategory (..),
-                                      PaymentId)
+import           Common.Model        (Frequency, Init (..), Payment (..),
+                                      PaymentCategory (..), PaymentId,
+                                      SavedPayment (..))
 import qualified Common.Util.Text    as T
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
@@ -36,15 +36,19 @@ widget paymentIn = do
     rec
       let init = _paymentIn_init paymentIn
           paymentsPerPage = 7
+          savedPayments = R.leftmost
+            [ _headerOut_addPayment header
+            , _tableOut_addPayment table
+            ]
 
       payments <- getPayments
         (_init_payments init)
-        (_createdPayment_payment <$> _headerOut_addPayment header)
+        (_savedPayment_payment <$> savedPayments)
         (_tableOut_deletePayment table)
 
       paymentCategories <- getPaymentCategories
         (_init_paymentCategories init)
-        (_createdPayment_paymentCategory <$> _headerOut_addPayment header)
+        (_savedPayment_paymentCategory <$> savedPayments)
         payments
         (_tableOut_deletePayment table)
 
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 69e29a7..88806bc 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -1,161 +1,54 @@
 module View.Payment.Add
   ( view
-  , AddIn(..)
-  , AddOut(..)
+  , Input(..)
   ) where
 
 import           Control.Monad             (join)
 import           Control.Monad.IO.Class    (liftIO)
-import qualified Data.List                 as L
-import qualified Data.Map                  as M
-import qualified Data.Maybe                as Maybe
-import           Data.Text                 (Text)
 import qualified Data.Text                 as T
-import qualified Data.Time.Calendar        as Calendar
 import qualified Data.Time.Clock           as Time
-import qualified Data.Validation           as V
-import           Reflex.Dom                (Dynamic, Event, MonadWidget, Reflex)
+import           Reflex.Dom                (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom                as R
-import qualified Text.Read                 as T
 
-import           Common.Model              (Category (..), CategoryId,
-                                            CreatePayment (..),
-                                            CreatedPayment (..), Frequency (..),
-                                            Payment (..), PaymentCategory (..))
+import           Common.Model              (Category (..), CreatePayment (..),
+                                            Frequency (..), Payment (..),
+                                            PaymentCategory (..),
+                                            SavedPayment (..))
 import qualified Common.Msg                as Msg
-import qualified Common.Util.Time          as Time
+import qualified Common.Util.Time          as TimeUtil
 import qualified Common.Validation.Payment as PaymentValidation
-import           Component                 (ButtonIn (..), InputIn (..),
-                                            InputOut (..), SelectIn (..),
-                                            SelectOut (..))
-import qualified Component                 as Component
-import qualified Util.Ajax                 as Ajax
-import qualified Util.Either               as EitherUtil
-import qualified Util.Validation           as ValidationUtil
-import qualified Util.WaitFor              as WaitFor
-
-data AddIn t = AddIn
-  { _addIn_categories        :: [Category]
-  , _addIn_paymentCategories :: Dynamic t [PaymentCategory]
-  , _addIn_frequency         :: Dynamic t Frequency
-  , _addIn_cancel            :: Event t ()
-  }
-
-data AddOut t = AddOut
-  { _addOut_cancel             :: Event t ()
-  , _addOut_addPayment         :: Event t CreatedPayment
-  , _addOut_addPaymentCategory :: Event t PaymentCategory
+import qualified Component.Modal           as Modal
+import qualified Util.Reflex               as ReflexUtil
+import qualified View.Payment.Form         as Form
+
+data Input t = Input
+  { _input_categories        :: [Category]
+  , _input_paymentCategories :: Dynamic t [PaymentCategory]
+  , _input_frequency         :: Dynamic t Frequency
   }
 
-view :: forall t m. MonadWidget t m => AddIn t -> m (AddOut t)
-view addIn = do
-  R.divClass "add" $ do
-    R.divClass "addHeader" $ R.text $ Msg.get Msg.Payment_Add
-
-    R.divClass "addContent" $ do
-      rec
-        let reset = R.leftmost
-              [ "" <$ cancel
-              , "" <$ addPayment
-              , "" <$ _addIn_cancel addIn
-              ]
-
-        name <- Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Payment_Name
-            , _inputIn_validation = PaymentValidation.name
-            })
-          reset
-          confirm
-
-        cost <- _inputOut_value <$> (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Payment_Cost
-            , _inputIn_validation = PaymentValidation.cost
-            })
-          reset
-          confirm)
-
-        now <- liftIO Time.getCurrentTime
-
-        currentDay <- do
-          d <- liftIO $ Time.timeToDay now
-          return . T.pack . Calendar.showGregorian $ d
-
-        date <- _inputOut_value <$> (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Payment_Date
-            , _inputIn_initialValue = currentDay
-            , _inputIn_inputType = "date"
-            , _inputIn_hasResetButton = False
-            , _inputIn_validation = PaymentValidation.date
-            })
-          (currentDay <$ reset)
-          confirm)
-
-        let setCategory =
-              R.fmapMaybe id
-                . R.updated
-                $ findCategory <$> (_inputOut_raw name) <*> (_addIn_paymentCategories addIn)
-
-        category <- _selectOut_value <$> (Component.select $ SelectIn
-          { _selectIn_label = Msg.get Msg.Payment_Category
-          , _selectIn_initialValue = -1
-          , _selectIn_value = setCategory
-          , _selectIn_values = R.constDyn categories
-          , _selectIn_reset = reset
-          , _selectIn_isValid = \id -> id /= -1
-          , _selectIn_validate = confirm
-          })
-
-        let payment = do
-              n <- _inputOut_value name
-              c <- cost
-              d <- date
-              cat <- category
-              f <- _addIn_frequency addIn
-              return (CreatePayment
-                <$> ValidationUtil.nelError n
-                <*> ValidationUtil.nelError c
-                <*> ValidationUtil.nelError d
-                <*> ValidationUtil.nelError cat
-                <*> V.Success f)
-
-        (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
-          rec
-            cancel <- Component._buttonOut_clic <$> (Component.button $
-              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-                { _buttonIn_class = R.constDyn "undo" })
-
-            confirm <- Component._buttonOut_clic <$> (Component.button $
-              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
-                { _buttonIn_class = R.constDyn "confirm"
-                , _buttonIn_waiting = waiting
-                , _buttonIn_submit = True
-                })
-
-            (addPayment, waiting) <- WaitFor.waitFor
-              (Ajax.postJson "/payment")
-              (ValidationUtil.fireValidation payment confirm)
-
-          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
-
-      return AddOut
-        { _addOut_cancel = cancel
-        , _addOut_addPayment = addPayment
-        }
-
-  where
-    frequencies = M.fromList
-      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
-      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
-      ]
-
-    categories = M.fromList . flip map (_addIn_categories addIn) $ \c ->
-      (_category_id c, _category_name c)
-
-
-findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
-findCategory paymentName =
-  fmap _paymentCategory_category
-    . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
+view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view input cancel = do
+
+  currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+  formOutput <- R.dyn $ do
+    paymentCategories <- _input_paymentCategories input
+    frequency <- _input_frequency input
+    return $ Form.view $ Form.Input
+      { Form._input_cancel = cancel
+      , Form._input_headerLabel = Msg.get Msg.Payment_Add
+      , Form._input_categories = _input_categories input
+      , Form._input_paymentCategories = paymentCategories
+      , Form._input_name = ""
+      , Form._input_cost = ""
+      , Form._input_date = currentDay
+      , Form._input_category = -1
+      , Form._input_frequency = frequency
+      , Form._input_mkPayload = CreatePayment
+      }
+
+  hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
+  addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
+
+  return (hide, addPayment)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
new file mode 100644
index 0000000..5624f6c
--- /dev/null
+++ b/client/src/View/Payment/Clone.hs
@@ -0,0 +1,60 @@
+module View.Payment.Clone
+  ( Input(..)
+  , view
+  ) where
+
+import qualified Control.Monad             as Monad
+import           Control.Monad.IO.Class    (liftIO)
+import qualified Data.Text                 as T
+import qualified Data.Time.Clock           as Time
+import           Reflex.Dom                (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom                as R
+
+import           Common.Model              (Category (..), CategoryId,
+                                            CreatePayment (..), Frequency (..),
+                                            Payment (..), PaymentCategory (..),
+                                            SavedPayment (..))
+import qualified Common.Msg                as Msg
+import qualified Common.Util.Time          as TimeUtil
+import qualified Common.Validation.Payment as PaymentValidation
+import qualified Component.Modal           as Modal
+import qualified Util.Reflex               as ReflexUtil
+import qualified View.Payment.Form         as Form
+
+data Input t = Input
+  { _input_show              :: Event t ()
+  , _input_categories        :: [Category]
+  , _input_paymentCategories :: Dynamic t [PaymentCategory]
+  , _input_payment           :: Dynamic t Payment
+  , _input_category          :: Dynamic t CategoryId
+  }
+
+view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view input cancel = do
+
+  currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+  formOutput <- R.dyn $ do
+    paymentCategories <- _input_paymentCategories input
+    payment <- _input_payment input
+    category <- _input_category input
+    return . Form.view $ Form.Input
+      { Form._input_cancel = cancel
+      , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong
+      , Form._input_categories = _input_categories input
+      , Form._input_paymentCategories = paymentCategories
+      , Form._input_name = _payment_name payment
+      , Form._input_cost = T.pack . show . _payment_cost $ payment
+      , Form._input_date = currentDay
+      , Form._input_category = category
+      , Form._input_frequency = _payment_frequency payment
+      , Form._input_mkPayload = CreatePayment
+      }
+
+  hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
+  clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
+
+  return $
+    ( hide
+    , clonePayment
+    )
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 65ce660..e7e319e 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -1,39 +1,34 @@
 module View.Payment.Delete
-  ( view
-  , DeleteIn(..)
-  , DeleteOut(..)
+  ( Input(..)
+  , view
   ) where
 
-import           Data.Text    (Text)
-import qualified Data.Text    as T
-import           Reflex.Dom   (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom   as R
-
-import           Common.Model (Payment (..))
-import qualified Common.Msg   as Msg
-import           Component    (ButtonIn (..), ButtonOut (..))
-import qualified Component    as Component
-import qualified Util.Ajax    as Ajax
-import qualified Util.Either  as EitherUtil
-import qualified Util.WaitFor as WaitFor
-
-data DeleteIn t = DeleteIn
-  { _deleteIn_payment :: Dynamic t Payment
-  }
-
-data DeleteOut t = DeleteOut
-  { _deleteOut_cancel   :: Event t ()
-  , _deleteOut_validate :: Event t Payment
+import           Data.Text       (Text)
+import qualified Data.Text       as T
+import           Reflex.Dom      (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom      as R
+
+import           Common.Model    (Payment (..))
+import qualified Common.Msg      as Msg
+import           Component       (ButtonIn (..), ButtonOut (..))
+import qualified Component       as Component
+import qualified Component.Modal as Modal
+import qualified Util.Ajax       as Ajax
+import qualified Util.Either     as EitherUtil
+import qualified Util.WaitFor    as WaitFor
+
+data Input t = Input
+  { _input_payment :: Dynamic t Payment
   }
 
-view :: forall t m. MonadWidget t m => (DeleteIn t) -> m (DeleteOut t)
-view deleteIn =
+view :: forall t m. MonadWidget t m => (Input t) -> Modal.Content t m Payment
+view input _ =
   R.divClass "delete" $ do
     R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
 
     R.divClass "deleteContent" $ do
 
-      (deletedPayment, cancel) <- R.divClass "buttons" $ do
+      (confirm, cancel) <- R.divClass "buttons" $ do
 
         cancel <- Component._buttonOut_clic <$> (Component.button $
           (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
@@ -48,7 +43,7 @@ view deleteIn =
               })
 
           let url =
-                R.ffor (_deleteIn_payment deleteIn) (\id ->
+                R.ffor (_input_payment input) (\id ->
                   T.concat ["/payment/", T.pack . show $ _payment_id id]
                 )
 
@@ -58,7 +53,7 @@ view deleteIn =
 
         return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
 
-      return DeleteOut
-        { _deleteOut_cancel = cancel
-        , _deleteOut_validate = R.tag (R.current $ _deleteIn_payment deleteIn) deletedPayment
-        }
+      return $
+        ( R.leftmost [ cancel, () <$ confirm ]
+        , R.tag (R.current $ _input_payment input) confirm
+        )
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
new file mode 100644
index 0000000..5020e57
--- /dev/null
+++ b/client/src/View/Payment/Edit.hs
@@ -0,0 +1,55 @@
+module View.Payment.Edit
+  ( Input(..)
+  , view
+  ) where
+
+import qualified Control.Monad             as Monad
+import qualified Data.Text                 as T
+import           Reflex.Dom                (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom                as R
+
+import           Common.Model              (Category (..), CategoryId,
+                                            EditPayment (..), Frequency (..),
+                                            Payment (..), PaymentCategory (..),
+                                            SavedPayment (..))
+import qualified Common.Msg                as Msg
+import qualified Common.Validation.Payment as PaymentValidation
+import qualified Component.Modal           as Modal
+import qualified Util.Reflex               as ReflexUtil
+import qualified View.Payment.Form         as Form
+
+data Input t = Input
+  { _input_show              :: Event t ()
+  , _input_categories        :: [Category]
+  , _input_paymentCategories :: Dynamic t [PaymentCategory]
+  , _input_payment           :: Dynamic t Payment
+  , _input_category          :: Dynamic t CategoryId
+  }
+
+view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view input cancel = do
+
+  formOutput <- R.dyn $ do
+    paymentCategories <- _input_paymentCategories input
+    payment <- _input_payment input
+    category <- _input_category input
+    return . Form.view $ Form.Input
+      { Form._input_cancel = cancel
+      , Form._input_headerLabel = Msg.get Msg.Payment_EditLong
+      , Form._input_categories = _input_categories input
+      , Form._input_paymentCategories = paymentCategories
+      , Form._input_name = _payment_name payment
+      , Form._input_cost = T.pack . show . _payment_cost $ payment
+      , Form._input_date = _payment_date payment
+      , Form._input_category = category
+      , Form._input_frequency = _payment_frequency payment
+      , Form._input_mkPayload = EditPayment (_payment_id payment)
+      }
+
+  hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
+  editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
+
+  return $
+    ( hide
+    , editPayment
+    )
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
new file mode 100644
index 0000000..ba54957
--- /dev/null
+++ b/client/src/View/Payment/Form.hs
@@ -0,0 +1,165 @@
+module View.Payment.Form
+  ( view
+  , Input(..)
+  , Output(..)
+  ) where
+
+import           Control.Monad             (join)
+import           Control.Monad.IO.Class    (liftIO)
+import           Data.Aeson                (ToJSON)
+import qualified Data.List                 as L
+import qualified Data.Map                  as M
+import qualified Data.Maybe                as Maybe
+import           Data.Text                 (Text)
+import qualified Data.Text                 as T
+import           Data.Time.Calendar        (Day)
+import qualified Data.Time.Calendar        as Calendar
+import qualified Data.Validation           as V
+import           Reflex.Dom                (Dynamic, Event, MonadHold,
+                                            MonadWidget, Reflex)
+import qualified Reflex.Dom                as R
+import qualified Text.Read                 as T
+
+import           Common.Model              (Category (..), CategoryId,
+                                            Frequency (..), Payment (..),
+                                            PaymentCategory (..),
+                                            SavedPayment (..))
+import qualified Common.Msg                as Msg
+import qualified Common.Validation.Payment as PaymentValidation
+import           Component                 (ButtonIn (..), InputIn (..),
+                                            InputOut (..), SelectIn (..),
+                                            SelectOut (..))
+import qualified Component                 as Component
+import qualified Util.Ajax                 as Ajax
+import qualified Util.Either               as EitherUtil
+import qualified Util.Validation           as ValidationUtil
+import qualified Util.WaitFor              as WaitFor
+
+data Input t p = Input
+  { _input_cancel            :: Event t ()
+  , _input_headerLabel       :: Text
+  , _input_categories        :: [Category]
+  , _input_paymentCategories :: [PaymentCategory]
+  , _input_name              :: Text
+  , _input_cost              :: Text
+  , _input_date              :: Day
+  , _input_category          :: CategoryId
+  , _input_frequency         :: Frequency
+  , _input_mkPayload         :: Text -> Int -> Day -> CategoryId -> Frequency -> p
+  }
+
+data Output t = Output
+  { _output_hide       :: Event t ()
+  , _output_addPayment :: Event t SavedPayment
+  }
+
+view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t)
+view input = do
+  R.divClass "form" $ do
+    R.divClass "formHeader" $
+      R.text (_input_headerLabel input)
+
+    R.divClass "formContent" $ do
+      rec
+        let reset = R.leftmost
+              [ "" <$ cancel
+              , "" <$ addPayment
+              , "" <$ _input_cancel input
+              ]
+
+        name <- Component.input
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Payment_Name
+            , _inputIn_initialValue = _input_name input
+            , _inputIn_validation = PaymentValidation.name
+            })
+          (_input_name input <$ reset)
+          confirm
+
+        cost <- _inputOut_value <$> (Component.input
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Payment_Cost
+            , _inputIn_initialValue = _input_cost input
+            , _inputIn_validation = PaymentValidation.cost
+            })
+          (_input_cost input <$ reset)
+          confirm)
+
+        let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
+
+        date <- _inputOut_value <$> (Component.input
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Payment_Date
+            , _inputIn_initialValue = initialDate
+            , _inputIn_inputType = "date"
+            , _inputIn_hasResetButton = False
+            , _inputIn_validation = PaymentValidation.date
+            })
+          (initialDate <$ reset)
+          confirm)
+
+        let setCategory =
+              R.fmapMaybe id . R.updated $
+                R.ffor (_inputOut_raw name) $ \name ->
+                  findCategory name (_input_paymentCategories input)
+
+        category <- _selectOut_value <$> (Component.select $ SelectIn
+          { _selectIn_label = Msg.get Msg.Payment_Category
+          , _selectIn_initialValue = _input_category input
+          , _selectIn_value = setCategory
+          , _selectIn_values = R.constDyn categories
+          , _selectIn_reset = _input_category input <$ reset
+          , _selectIn_isValid = (/= -1)
+          , _selectIn_validate = confirm
+          })
+
+        let payment = do
+              n <- _inputOut_value name
+              c <- cost
+              d <- date
+              cat <- category
+              return ((_input_mkPayload input)
+                <$> ValidationUtil.nelError n
+                <*> ValidationUtil.nelError c
+                <*> ValidationUtil.nelError d
+                <*> ValidationUtil.nelError cat
+                <*> V.Success (_input_frequency input))
+
+        (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
+          rec
+            cancel <- Component._buttonOut_clic <$> (Component.button $
+              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+                { _buttonIn_class = R.constDyn "undo" })
+
+            confirm <- Component._buttonOut_clic <$> (Component.button $
+              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+                { _buttonIn_class = R.constDyn "confirm"
+                , _buttonIn_waiting = waiting
+                , _buttonIn_submit = True
+                })
+
+            (addPayment, waiting) <- WaitFor.waitFor
+              (Ajax.postJson "/payment")
+              (ValidationUtil.fireValidation payment confirm)
+
+          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
+
+      return Output
+        { _output_hide = R.leftmost [ cancel, () <$ addPayment ]
+        , _output_addPayment = addPayment
+        }
+
+  where
+    frequencies = M.fromList
+      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+      ]
+
+    categories = M.fromList . flip map (_input_categories input) $ \c ->
+      (_category_id c, _category_name c)
+
+
+findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
+findCategory paymentName =
+  fmap _paymentCategory_category
+    . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 1bdee8d..7281195 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -17,10 +17,10 @@ import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Category, CreatedPayment (..),
-                                         Currency, ExceedingPayer (..),
-                                         Frequency (..), Income (..), Init (..),
-                                         Payment (..), PaymentCategory,
+import           Common.Model           (Category, Currency,
+                                         ExceedingPayer (..), Frequency (..),
+                                         Income (..), Init (..), Payment (..),
+                                         PaymentCategory, SavedPayment (..),
                                          User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
@@ -28,11 +28,10 @@ import qualified Common.View.Format     as Format
 
 import           Component              (ButtonIn (..), ButtonOut (..),
                                          InputIn (..), InputOut (..),
-                                         ModalIn (..), ModalOut (..),
                                          SelectIn (..), SelectOut (..))
 import qualified Component              as Component
+import qualified Component.Modal        as Modal
 import qualified Util.List              as L
-import           View.Payment.Add       (AddIn (..), AddOut (..))
 import qualified View.Payment.Add       as Add
 
 data HeaderIn t = HeaderIn
@@ -45,7 +44,7 @@ data HeaderIn t = HeaderIn
 data HeaderOut t = HeaderOut
   { _headerOut_searchName      :: Dynamic t Text
   , _headerOut_searchFrequency :: Dynamic t Frequency
-  , _headerOut_addPayment      :: Event t CreatedPayment
+  , _headerOut_addPayment      :: Event t SavedPayment
   }
 
 widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
@@ -90,7 +89,7 @@ payerAndAdd
   -> Dynamic t [PaymentCategory]
   -> Currency
   -> Dynamic t Frequency
-  -> m (Event t CreatedPayment)
+  -> m (Event t SavedPayment)
 payerAndAdd incomes payments users categories paymentCategories currency frequency = do
   time <- liftIO Time.getCurrentTime
   R.divClass "payerAndAdd" $ do
@@ -119,22 +118,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
       , _buttonIn_submit = False
       })
 
-    rec
-      modalOut <- Component.modal $ ModalIn
-        { _modalIn_show    = addPaymentClic
-        , _modalIn_hide = R.leftmost $
-            [ _addOut_cancel addOut
-            , fmap (const ()) . _addOut_addPayment $ addOut
-            ]
-        , _modalIn_content = Add.view $ AddIn
-            { _addIn_categories = categories
-            , _addIn_paymentCategories = paymentCategories
-            , _addIn_frequency = frequency
-            , _addIn_cancel = _modalOut_hide modalOut
-            }
-        }
-      let addOut = _modalOut_content modalOut
-    return (_addOut_addPayment addOut)
+    Modal.view $ Modal.Input
+      { Modal._input_show    = addPaymentClic
+      , Modal._input_content = Add.view $ Add.Input
+          { Add._input_categories = categories
+          , Add._input_paymentCategories = paymentCategories
+          , Add._input_frequency = frequency
+          }
+      }
 
 searchLine
   :: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index cbe7b50..9247143 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -4,15 +4,15 @@ module View.Payment.Pages
   , PagesOut(..)
   ) where
 
-import qualified Data.Text  as T
-import           Reflex.Dom (Dynamic, Event, 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           Component  (ButtonIn (..), ButtonOut (..))
-import qualified Component  as Component
+import           Component   (ButtonIn (..), ButtonOut (..))
+import qualified Component   as Component
 
 import qualified Icon
-import qualified Util.Dom   as Dom
+import qualified Util.Reflex as ReflexUtil
 
 data PagesIn t = PagesIn
   { _pagesIn_total   :: Dynamic t Int
@@ -26,7 +26,7 @@ data PagesOut t = PagesOut
 
 widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
 widget pagesIn = do
-  currentPage <- Dom.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
+  currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
 
   return $ PagesOut
     { _pagesOut_currentPage = currentPage
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index b09f30f..f2b8870 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -6,25 +6,32 @@ module View.Payment.Table
 
 import qualified Data.List           as L
 import qualified Data.Map            as M
+import qualified Data.Maybe          as Maybe
 import           Data.Text           (Text)
 import qualified Data.Text           as T
 import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Category (..), Init (..), Payment (..),
-                                      PaymentCategory (..), User (..))
+import           Common.Model        (Category (..), Frequency (Punctual),
+                                      Init (..), Payment (..),
+                                      PaymentCategory (..), SavedPayment,
+                                      User (..))
 import qualified Common.Model        as CM
 import qualified Common.Msg          as Msg
 import qualified Common.View.Format  as Format
-import           Component           (ButtonIn (..), ButtonOut (..),
-                                      ModalIn (..), ModalOut (..))
+import           Component           (ButtonIn (..), ButtonOut (..))
 import qualified Component           as Component
-import           View.Payment.Delete (DeleteIn (..), DeleteOut (..))
+import qualified Component.Modal     as Modal
+import qualified View.Payment.Clone  as Clone
 import qualified View.Payment.Delete as Delete
+import qualified View.Payment.Edit   as Edit
 
 import qualified Icon
-import qualified Util.Dom            as DomUtil
+import qualified Util.Reflex         as ReflexUtil
+
+-- TODO: remove
+import           Debug.Trace         (trace)
 
 data TableIn t = TableIn
   { _tableIn_init              :: Init
@@ -32,17 +39,19 @@ data TableIn t = TableIn
   , _tableIn_payments          :: Dynamic t [Payment]
   , _tableIn_perPage           :: Int
   , _tableIn_paymentCategories :: Dynamic t [PaymentCategory]
+  , _tableIn_categories        :: [Category]
   }
 
 data TableOut t = TableOut
-  { _tableOut_deletePayment :: Event t Payment
+  { _tableOut_addPayment    :: Event t SavedPayment
+  , _tableOut_deletePayment :: Event t Payment
   }
 
 widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    deletePayment <- R.divClass "lines" $ do
+    (addPayment, deletePayment) <- R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
         R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -52,14 +61,21 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
         R.divClass "cell" $ R.blank
-      (R.switch . R.current . fmap R.leftmost) <$>
+
+      result <-
         (R.simpleList paymentRange (paymentRow init paymentCategories))
 
-    DomUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
+      return $
+        ( R.switch . R.current . fmap (R.leftmost . map fst) $ result
+        , R.switch . R.current . fmap (R.leftmost . map snd) $ result
+        )
+
+    ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
     return $ TableOut
-      { _tableOut_deletePayment = deletePayment
+      { _tableOut_addPayment = addPayment
+      , _tableOut_deletePayment = deletePayment
       }
 
   where
@@ -82,7 +98,7 @@ paymentRow
   => Init
   -> Dynamic t [PaymentCategory]
   -> Dynamic t Payment
-  -> m (Event t Payment)
+  -> m (Event t SavedPayment, Event t Payment)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
 
@@ -115,7 +131,7 @@ paymentRow init paymentCategories payment =
             Nothing -> M.singleton "display" "none"
 
       R.elDynAttr "span" attrs $
-        R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of
+        R.dynText $ R.ffor category $ \case
           Just c -> _category_name c
           _      -> ""
 
@@ -123,35 +139,68 @@ paymentRow init paymentCategories 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
+    let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category
+
+    clonePayment <-
+      R.divClass "cell button" $
+        _buttonOut_clic <$> (Component.button $
+          Component.defaultButtonIn Icon.clone)
+
+    paymentCloned <-
+      Modal.view $ Modal.Input
+        { Modal._input_show    = clonePayment
+        , Modal._input_content =
+            Clone.view $ Clone.Input
+              { Clone._input_show = clonePayment
+              , Clone._input_categories = _init_categories init
+              , Clone._input_paymentCategories = paymentCategories
+              , Clone._input_payment = payment
+              , Clone._input_category = categoryId
+              }
+        }
 
     let isFromCurrentUser =
           R.ffor
             payment
             (\p -> _payment_user p == _init_currentUser init)
 
-    R.divClass "cell button" $
-      DomUtil.divVisibleIf isFromCurrentUser $
-        R.el "button" Icon.edit
+    editPayment <-
+      R.divClass "cell button" $
+        ReflexUtil.divVisibleIf isFromCurrentUser $
+          _buttonOut_clic <$> (Component.button $
+            Component.defaultButtonIn Icon.edit)
+
+    paymentEdited <-
+      Modal.view $ Modal.Input
+        { Modal._input_show    = editPayment
+        , Modal._input_content =
+            Edit.view $ Edit.Input
+              { Edit._input_show = editPayment
+              , Edit._input_categories = _init_categories init
+              , Edit._input_paymentCategories = paymentCategories
+              , Edit._input_payment = payment
+              , Edit._input_category = categoryId
+              }
+        }
 
     deletePayment <-
       R.divClass "cell button" $
-        DomUtil.divVisibleIf isFromCurrentUser $
+        ReflexUtil.divVisibleIf isFromCurrentUser $
           _buttonOut_clic <$> (Component.button $
             (Component.defaultButtonIn Icon.delete)
-              { _buttonIn_class = R.constDyn "deletePayment" })
-
-    rec
-      modalOut <- Component.modal $ ModalIn
-        { _modalIn_show    = deletePayment
-        , _modalIn_hide = R.leftmost $
-            [ _deleteOut_cancel . _modalOut_content $ modalOut
-            , fmap (const ()) . _deleteOut_validate . _modalOut_content $ modalOut
-            ]
-        , _modalIn_content = Delete.view (DeleteIn { _deleteIn_payment = payment })
+              { _buttonIn_class = R.constDyn "deletePayment"
+              })
+
+    paymentDeleted <-
+      Modal.view $ Modal.Input
+        { Modal._input_show    = deletePayment
+        , Modal._input_content =
+            Delete.view $ Delete.Input
+              { Delete._input_payment = payment
+              }
         }
-    return (_deleteOut_validate . _modalOut_content $ modalOut)
+
+    return $ (paymentCloned, paymentDeleted)
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
-- 
cgit v1.2.3


From f4c5df9e1b1afddeb5a482d4fbe654d0b321159c Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 6 Oct 2019 19:28:54 +0200
Subject: Make payment edition to work on the frontend

---
 client/src/Util/Ajax.hs          | 63 +++++++++++++++++++++++++++++-----------
 client/src/View/Payment.hs       | 38 ++++++++++++++++--------
 client/src/View/Payment/Add.hs   |  1 +
 client/src/View/Payment/Clone.hs |  1 +
 client/src/View/Payment/Edit.hs  |  1 +
 client/src/View/Payment/Form.hs  | 19 ++++++++----
 client/src/View/Payment/Table.hs | 13 +++++----
 7 files changed, 97 insertions(+), 39 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 7b65c52..a4f6a74 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,20 +1,24 @@
 module Util.Ajax
   ( postJson
+  , putJson
   , delete
   ) where
 
-import           Control.Arrow      (left)
-import           Data.Aeson         (FromJSON, ToJSON)
-import qualified Data.Aeson         as Aeson
-import           Data.Default       (def)
-import qualified Data.Map.Lazy      as LM
-import           Data.Text          (Text)
-import qualified Data.Text          as T
-import qualified Data.Text.Encoding as T
-import           Reflex.Dom         (Dynamic, Event, IsXhrPayload, MonadWidget,
-                                     XhrRequest, XhrRequestConfig (..),
-                                     XhrResponse, XhrResponseHeaders (..))
-import qualified Reflex.Dom         as R
+import           Control.Arrow        (left)
+import           Data.Aeson           (FromJSON, ToJSON)
+import qualified Data.Aeson           as Aeson
+import           Data.ByteString      (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Default         (def)
+import qualified Data.Map.Lazy        as LM
+import           Data.Text            (Text)
+import qualified Data.Text            as T
+import qualified Data.Text.Encoding   as T
+import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
+                                       MonadWidget, XhrRequest,
+                                       XhrRequestConfig (..), XhrResponse,
+                                       XhrResponseHeaders (..))
+import qualified Reflex.Dom           as R
 
 postJson
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
@@ -23,7 +27,16 @@ postJson
   -> m (Event t (Either Text b))
 postJson url input =
   fmap getJsonResult <$>
-    R.performRequestAsync (R.postJson url <$> input)
+    R.performRequestAsync (jsonRequest "POST" url <$> input)
+
+putJson
+  :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text b))
+putJson url input =
+  fmap getJsonResult <$>
+    R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
 delete
   :: forall t m a. (MonadWidget t m)
@@ -31,8 +44,9 @@ delete
   -> Event t ()
   -> m (Event t (Either Text Text))
 delete url fire = do
-  response <- R.performRequestAsync (R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
-  return $ fmap getResult response
+  fmap getResult <$>
+    (R.performRequestAsync $
+      R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
 
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
 getJsonResult response =
@@ -50,7 +64,22 @@ getResult response =
     _ -> Left "NoKey"
 
 request :: forall a. (IsXhrPayload a) => Text -> Text -> a -> XhrRequest a
-request method url sendData =
+request method url payload =
+  let
+    config = XhrRequestConfig
+      { _xhrRequestConfig_headers = def
+      , _xhrRequestConfig_user = def
+      , _xhrRequestConfig_password = def
+      , _xhrRequestConfig_responseType = def
+      , _xhrRequestConfig_responseHeaders = def
+      , _xhrRequestConfig_withCredentials = False
+      , _xhrRequestConfig_sendData = payload
+      }
+  in
+    R.xhrRequest method url config
+
+jsonRequest :: forall a. (ToJSON a) => Text -> Text -> a -> XhrRequest ByteString
+jsonRequest method url payload =
   let
     config = XhrRequestConfig
       { _xhrRequestConfig_headers = def
@@ -59,7 +88,7 @@ request method url sendData =
       , _xhrRequestConfig_responseType = def
       , _xhrRequestConfig_responseHeaders = def
       , _xhrRequestConfig_withCredentials = False
-      , _xhrRequestConfig_sendData = sendData
+      , _xhrRequestConfig_sendData = LBS.toStrict $ Aeson.encode payload
       }
   in
     R.xhrRequest method url config
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index ab83447..f2a5071 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -35,21 +35,25 @@ widget paymentIn = do
   R.elClass "main" "payment" $ do
     rec
       let init = _paymentIn_init paymentIn
+
           paymentsPerPage = 7
-          savedPayments = R.leftmost
+
+          addPayment = R.leftmost
             [ _headerOut_addPayment header
             , _tableOut_addPayment table
             ]
 
-      payments <- getPayments
+      payments <- reducePayments
         (_init_payments init)
-        (_savedPayment_payment <$> savedPayments)
+        (_savedPayment_payment <$> addPayment)
+        (_savedPayment_payment <$> _tableOut_editPayment table)
         (_tableOut_deletePayment table)
 
-      paymentCategories <- getPaymentCategories
+      paymentCategories <- reducePaymentCategories
         (_init_paymentCategories init)
-        (_savedPayment_paymentCategory <$> savedPayments)
         payments
+        (_savedPayment_paymentCategory <$> addPayment)
+        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
         (_tableOut_deletePayment table)
 
       (searchNameEvent, searchName) <-
@@ -93,28 +97,38 @@ debounceSearchName searchName = do
   dynamic <- R.holdDyn "" event
   return (event, dynamic)
 
-getPayments
+reducePayments
   :: forall t m. MonadWidget t m
   => [Payment]
-  -> Event t Payment
-  -> Event t Payment
+  -> Event t Payment -- add payment
+  -> Event t Payment -- edit payment
+  -> Event t Payment -- delete payment
   -> m (Dynamic t [Payment])
-getPayments initPayments addPayment deletePayment =
+reducePayments initPayments addPayment editPayment deletePayment =
   R.foldDyn id initPayments $ R.leftmost
     [ (:) <$> addPayment
+    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
     , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
     ]
 
-getPaymentCategories
+reducePaymentCategories
   :: forall t m. MonadWidget t m
   => [PaymentCategory]
-  -> Event t PaymentCategory  -- add payment category
   -> Dynamic t [Payment]      -- payments
+  -> Event t PaymentCategory  -- add payment category
+  -> Event t PaymentCategory  -- edit payment category
   -> Event t Payment          -- delete payment
   -> m (Dynamic t [PaymentCategory])
-getPaymentCategories initPaymentCategories addPaymentCategory payments deletePayment =
+reducePaymentCategories
+  initPaymentCategories
+  payments
+  addPaymentCategory
+  editPaymentCategory
+  deletePayment
+    =
   R.foldDyn id initPaymentCategories $ R.leftmost
     [ (:) <$> addPaymentCategory
+    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
     , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
     ]
   where
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 88806bc..e83dba9 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -46,6 +46,7 @@ view input cancel = do
       , Form._input_category = -1
       , Form._input_frequency = frequency
       , Form._input_mkPayload = CreatePayment
+      , Form._input_httpMethod = Form.Post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 5624f6c..922e89c 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -49,6 +49,7 @@ view input cancel = do
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
       , Form._input_mkPayload = CreatePayment
+      , Form._input_httpMethod = Form.Post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 5020e57..9c11af0 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -44,6 +44,7 @@ view input cancel = do
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
       , Form._input_mkPayload = EditPayment (_payment_id payment)
+      , Form._input_httpMethod = Form.Put
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index ba54957..9889638 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,6 +1,7 @@
 module View.Payment.Form
   ( view
   , Input(..)
+  , HttpMethod(..)
   , Output(..)
   ) where
 
@@ -46,8 +47,11 @@ data Input t p = Input
   , _input_category          :: CategoryId
   , _input_frequency         :: Frequency
   , _input_mkPayload         :: Text -> Int -> Day -> CategoryId -> Frequency -> p
+  , _input_httpMethod        :: HttpMethod
   }
 
+data HttpMethod = Put | Post
+
 data Output t = Output
   { _output_hide       :: Event t ()
   , _output_addPayment :: Event t SavedPayment
@@ -139,7 +143,7 @@ view input = do
                 })
 
             (addPayment, waiting) <- WaitFor.waitFor
-              (Ajax.postJson "/payment")
+              (ajax "/payment")
               (ValidationUtil.fireValidation payment confirm)
 
           return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
@@ -150,14 +154,19 @@ view input = do
         }
 
   where
-    frequencies = M.fromList
-      [ (Punctual, Msg.get Msg.Payment_PunctualMale)
-      , (Monthly, Msg.get Msg.Payment_MonthlyMale)
-      ]
+    frequencies =
+      M.fromList
+        [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+        , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+        ]
 
     categories = M.fromList . flip map (_input_categories input) $ \c ->
       (_category_id c, _category_name c)
 
+    ajax =
+      case _input_httpMethod input of
+        Post -> Ajax.postJson
+        Put  -> Ajax.putJson
 
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
 findCategory paymentName =
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index f2b8870..40bc864 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -44,6 +44,7 @@ data TableIn t = TableIn
 
 data TableOut t = TableOut
   { _tableOut_addPayment    :: Event t SavedPayment
+  , _tableOut_editPayment   :: Event t SavedPayment
   , _tableOut_deletePayment :: Event t Payment
   }
 
@@ -51,7 +52,7 @@ widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
 widget tableIn = do
   R.divClass "table" $ do
 
-    (addPayment, deletePayment) <- R.divClass "lines" $ do
+    (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do
       R.divClass "header" $ do
         R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
         R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
@@ -66,8 +67,9 @@ widget tableIn = do
         (R.simpleList paymentRange (paymentRow init paymentCategories))
 
       return $
-        ( R.switch . R.current . fmap (R.leftmost . map fst) $ result
-        , R.switch . R.current . fmap (R.leftmost . map snd) $ result
+        ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
+        , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
+        , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
         )
 
     ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
@@ -75,6 +77,7 @@ widget tableIn = do
 
     return $ TableOut
       { _tableOut_addPayment = addPayment
+      , _tableOut_editPayment = editPayment
       , _tableOut_deletePayment = deletePayment
       }
 
@@ -98,7 +101,7 @@ paymentRow
   => Init
   -> Dynamic t [PaymentCategory]
   -> Dynamic t Payment
-  -> m (Event t SavedPayment, Event t Payment)
+  -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
 paymentRow init paymentCategories payment =
   R.divClass "row" $ do
 
@@ -200,7 +203,7 @@ paymentRow init paymentCategories payment =
               }
         }
 
-    return $ (paymentCloned, paymentDeleted)
+    return $ (paymentCloned, paymentEdited, paymentDeleted)
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
-- 
cgit v1.2.3


From 2cbd43c3a0f0640776a4e7c7425b3210d2e6632b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 6 Oct 2019 19:41:17 +0200
Subject: Make input label clickable again

---
 client/src/Component/Input.hs  | 16 ++++++++++------
 client/src/Component/Select.hs | 16 +++++++++-------
 2 files changed, 19 insertions(+), 13 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index abdc51c..0c84754 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -75,13 +75,17 @@ input inputIn reset validate = do
 
     (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
 
-      textInput <- R.textInput $ R.def
-        & R.attributes .~ inputAttr
-        & R.setValue .~ resetValue
-        & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
-        & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
+      textInput <- R.el "label" $ do
+        textInput <- R.textInput $ R.def
+          & R.attributes .~ inputAttr
+          & R.setValue .~ resetValue
+          & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
+          & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
 
-      R.el "label" $ R.text (_inputIn_label inputIn)
+        R.divClass "label" $
+          R.text (_inputIn_label inputIn)
+
+        return textInput
 
       resetClic <-
         if _inputIn_hasResetButton inputIn
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 9a37afc..5980ed2 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -57,8 +57,6 @@ select selectIn = do
       ]
 
     value <- R.elDynAttr "div" containerAttr $ do
-      R.el "label" $ R.text (_selectIn_label selectIn)
-
       let initialValue = _selectIn_initialValue selectIn
 
       let setValue = R.leftmost
@@ -66,11 +64,15 @@ select selectIn = do
             , _selectIn_value selectIn
             ]
 
-      value <- R._dropdown_value <$>
-        R.dropdown
-          initialValue
-          (_selectIn_values selectIn)
-          (R.def { R._dropdownConfig_setValue = setValue })
+      value <- R.el "label" $ do
+        R.divClass "label" $
+          R.text (_selectIn_label selectIn)
+
+        R._dropdown_value <$>
+          R.dropdown
+            initialValue
+            (_selectIn_values selectIn)
+            (R.def { R._dropdownConfig_setValue = setValue })
 
       R.divClass "errorMessage" . R.dynText $
         R.ffor showedError (Maybe.fromMaybe "")
-- 
cgit v1.2.3


From 7529a18ff0ac443e7f9764b5e2d0f57a5d3a850b Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 9 Oct 2019 23:16:00 +0200
Subject: Use common payment validation in the backend

Remove deprecated backend validation
---
 client/src/Component/Select.hs    | 11 +++--------
 client/src/View/Payment/Add.hs    | 35 +++++++++++++++++------------------
 client/src/View/Payment/Clone.hs  | 35 +++++++++++++++++------------------
 client/src/View/Payment/Edit.hs   | 27 +++++++++++++--------------
 client/src/View/Payment/Form.hs   | 12 ++++++------
 client/src/View/Payment/Header.hs |  3 ++-
 6 files changed, 58 insertions(+), 65 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 5980ed2..102f554 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -9,11 +9,10 @@ import qualified Data.Map        as M
 import qualified Data.Maybe      as Maybe
 import           Data.Text       (Text)
 import qualified Data.Text       as T
-import           Data.Validation (Validation (Failure, Success))
+import           Data.Validation (Validation)
 import           Reflex.Dom      (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom      as R
 
-import qualified Common.Msg      as Msg
 import qualified Util.Validation as ValidationUtil
 
 data (Reflex t) => SelectIn t a b c = SelectIn
@@ -22,7 +21,7 @@ data (Reflex t) => SelectIn t a b c = SelectIn
   , _selectIn_value        :: Event t a
   , _selectIn_values       :: Dynamic t (Map a Text)
   , _selectIn_reset        :: Event t b
-  , _selectIn_isValid      :: a -> Bool
+  , _selectIn_isValid      :: a -> Validation Text a
   , _selectIn_validate     :: Event t c
   }
 
@@ -41,11 +40,7 @@ select selectIn = do
             ])
 
         validatedValue =
-          R.ffor value (\v ->
-            if _selectIn_isValid selectIn v then
-              Success v
-            else
-              Failure (Msg.get Msg.Form_NonEmpty))
+          fmap (_selectIn_isValid selectIn) value
 
         maybeError =
           fmap ValidationUtil.maybeError validatedValue
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index e83dba9..28c0148 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -3,23 +3,22 @@ module View.Payment.Add
   , Input(..)
   ) where
 
-import           Control.Monad             (join)
-import           Control.Monad.IO.Class    (liftIO)
-import qualified Data.Text                 as T
-import qualified Data.Time.Clock           as Time
-import           Reflex.Dom                (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom                as R
-
-import           Common.Model              (Category (..), CreatePayment (..),
-                                            Frequency (..), Payment (..),
-                                            PaymentCategory (..),
-                                            SavedPayment (..))
-import qualified Common.Msg                as Msg
-import qualified Common.Util.Time          as TimeUtil
-import qualified Common.Validation.Payment as PaymentValidation
-import qualified Component.Modal           as Modal
-import qualified Util.Reflex               as ReflexUtil
-import qualified View.Payment.Form         as Form
+import           Control.Monad          (join)
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Time
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Category (..), CreatePaymentForm (..),
+                                         Frequency (..), Payment (..),
+                                         PaymentCategory (..),
+                                         SavedPayment (..))
+import qualified Common.Msg             as Msg
+import qualified Common.Util.Time       as TimeUtil
+import qualified Component.Modal        as Modal
+import qualified Util.Reflex            as ReflexUtil
+import qualified View.Payment.Form      as Form
 
 data Input t = Input
   { _input_categories        :: [Category]
@@ -45,7 +44,7 @@ view input cancel = do
       , Form._input_date = currentDay
       , Form._input_category = -1
       , Form._input_frequency = frequency
-      , Form._input_mkPayload = CreatePayment
+      , Form._input_mkPayload = CreatePaymentForm
       , Form._input_httpMethod = Form.Post
       }
 
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 922e89c..60694ca 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -3,23 +3,22 @@ module View.Payment.Clone
   , view
   ) where
 
-import qualified Control.Monad             as Monad
-import           Control.Monad.IO.Class    (liftIO)
-import qualified Data.Text                 as T
-import qualified Data.Time.Clock           as Time
-import           Reflex.Dom                (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom                as R
-
-import           Common.Model              (Category (..), CategoryId,
-                                            CreatePayment (..), Frequency (..),
-                                            Payment (..), PaymentCategory (..),
-                                            SavedPayment (..))
-import qualified Common.Msg                as Msg
-import qualified Common.Util.Time          as TimeUtil
-import qualified Common.Validation.Payment as PaymentValidation
-import qualified Component.Modal           as Modal
-import qualified Util.Reflex               as ReflexUtil
-import qualified View.Payment.Form         as Form
+import qualified Control.Monad          as Monad
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Time
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Category (..), CategoryId,
+                                         CreatePaymentForm (..), Frequency (..),
+                                         Payment (..), PaymentCategory (..),
+                                         SavedPayment (..))
+import qualified Common.Msg             as Msg
+import qualified Common.Util.Time       as TimeUtil
+import qualified Component.Modal        as Modal
+import qualified Util.Reflex            as ReflexUtil
+import qualified View.Payment.Form      as Form
 
 data Input t = Input
   { _input_show              :: Event t ()
@@ -48,7 +47,7 @@ view input cancel = do
       , Form._input_date = currentDay
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
-      , Form._input_mkPayload = CreatePayment
+      , Form._input_mkPayload = CreatePaymentForm
       , Form._input_httpMethod = Form.Post
       }
 
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 9c11af0..0361602 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -3,20 +3,19 @@ module View.Payment.Edit
   , view
   ) where
 
-import qualified Control.Monad             as Monad
-import qualified Data.Text                 as T
-import           Reflex.Dom                (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom                as R
+import qualified Control.Monad     as Monad
+import qualified Data.Text         as T
+import           Reflex.Dom        (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom        as R
 
-import           Common.Model              (Category (..), CategoryId,
-                                            EditPayment (..), Frequency (..),
-                                            Payment (..), PaymentCategory (..),
-                                            SavedPayment (..))
-import qualified Common.Msg                as Msg
-import qualified Common.Validation.Payment as PaymentValidation
-import qualified Component.Modal           as Modal
-import qualified Util.Reflex               as ReflexUtil
-import qualified View.Payment.Form         as Form
+import           Common.Model      (Category (..), CategoryId,
+                                    EditPaymentForm (..), Frequency (..),
+                                    Payment (..), PaymentCategory (..),
+                                    SavedPayment (..))
+import qualified Common.Msg        as Msg
+import qualified Component.Modal   as Modal
+import qualified Util.Reflex       as ReflexUtil
+import qualified View.Payment.Form as Form
 
 data Input t = Input
   { _input_show              :: Event t ()
@@ -43,7 +42,7 @@ view input cancel = do
       , Form._input_date = _payment_date payment
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
-      , Form._input_mkPayload = EditPayment (_payment_id payment)
+      , Form._input_mkPayload = EditPaymentForm (_payment_id payment)
       , Form._input_httpMethod = Form.Put
       }
 
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 9889638..187b64b 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -46,7 +46,7 @@ data Input t p = Input
   , _input_date              :: Day
   , _input_category          :: CategoryId
   , _input_frequency         :: Frequency
-  , _input_mkPayload         :: Text -> Int -> Day -> CategoryId -> Frequency -> p
+  , _input_mkPayload         :: Text -> Text -> Text -> CategoryId -> Frequency -> p
   , _input_httpMethod        :: HttpMethod
   }
 
@@ -80,7 +80,7 @@ view input = do
           (_input_name input <$ reset)
           confirm
 
-        cost <- _inputOut_value <$> (Component.input
+        cost <- _inputOut_raw <$> (Component.input
           (Component.defaultInputIn
             { _inputIn_label = Msg.get Msg.Payment_Cost
             , _inputIn_initialValue = _input_cost input
@@ -91,7 +91,7 @@ view input = do
 
         let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
 
-        date <- _inputOut_value <$> (Component.input
+        date <- _inputOut_raw <$> (Component.input
           (Component.defaultInputIn
             { _inputIn_label = Msg.get Msg.Payment_Date
             , _inputIn_initialValue = initialDate
@@ -113,7 +113,7 @@ view input = do
           , _selectIn_value = setCategory
           , _selectIn_values = R.constDyn categories
           , _selectIn_reset = _input_category input <$ reset
-          , _selectIn_isValid = (/= -1)
+          , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
           , _selectIn_validate = confirm
           })
 
@@ -124,8 +124,8 @@ view input = do
               cat <- category
               return ((_input_mkPayload input)
                 <$> ValidationUtil.nelError n
-                <*> ValidationUtil.nelError c
-                <*> ValidationUtil.nelError d
+                <*> V.Success c
+                <*> V.Success d
                 <*> ValidationUtil.nelError cat
                 <*> V.Success (_input_frequency input))
 
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 7281195..6ed3b0e 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -13,6 +13,7 @@ import           Data.Text              (Text)
 import qualified Data.Text              as T
 import           Data.Time              (NominalDiffTime)
 import qualified Data.Time              as Time
+import qualified Data.Validation        as V
 import           Prelude                hiding (init)
 import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom             as R
@@ -150,7 +151,7 @@ searchLine reset = do
         , _selectIn_value        = R.never
         , _selectIn_values       = R.constDyn frequencies
         , _selectIn_reset        = R.never
-        , _selectIn_isValid      = const True
+        , _selectIn_isValid      = V.Success
         , _selectIn_validate     = R.never
         })
 
-- 
cgit v1.2.3


From 52331eeadce8d250564851c25fc965172640bc55 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 12 Oct 2019 11:23:10 +0200
Subject: Implement client routing

---
 client/src/Component.hs           |   1 +
 client/src/Component/Link.hs      |  33 +++++
 client/src/Model/Route.hs         |   9 ++
 client/src/Util/Css.hs            |   9 ++
 client/src/Util/Router.hs         | 266 ++++++++++++++++++++++++++++++++++++++
 client/src/View/App.hs            |  87 +++++++++----
 client/src/View/Header.hs         |  65 +++++++---
 client/src/View/NotFound.hs       |  20 +++
 client/src/View/Payment.hs        |   9 +-
 client/src/View/Payment/Delete.hs |   2 +-
 client/src/View/Payment/Form.hs   |   2 +-
 client/src/View/SignIn.hs         |   2 +-
 12 files changed, 457 insertions(+), 48 deletions(-)
 create mode 100644 client/src/Component/Link.hs
 create mode 100644 client/src/Model/Route.hs
 create mode 100644 client/src/Util/Css.hs
 create mode 100644 client/src/Util/Router.hs
 create mode 100644 client/src/View/NotFound.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index 7b87a75..7e0b151 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -3,5 +3,6 @@ module Component (module X) where
 import           Component.Button as X
 import           Component.Form   as X
 import           Component.Input  as X
+import           Component.Link   as X
 import           Component.Modal  as X
 import           Component.Select as X
diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs
new file mode 100644
index 0000000..7e8558b
--- /dev/null
+++ b/client/src/Component/Link.hs
@@ -0,0 +1,33 @@
+module Component.Link
+  ( link
+  ) where
+
+import           Data.Map   (Map)
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import qualified Data.Text  as T
+import           Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m ()
+link href inputAttrs content =
+  R.elDynAttr "a" attrs (R.text content)
+  where
+
+    onclickHandler =
+      T.intercalate ";"
+        [ "history.pushState(0, '', event.target.href)"
+        , "dispatchEvent(new PopStateEvent('popstate', {cancelable: true, bubbles: true, view: window}))"
+        , "return false"
+        ]
+
+    attrs =
+      R.ffor inputAttrs (\as ->
+        (M.union
+          (M.fromList
+            [ ("onclick", onclickHandler)
+            , ("href", href)
+            ]
+          )
+          as)
+      )
diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs
new file mode 100644
index 0000000..420fe05
--- /dev/null
+++ b/client/src/Model/Route.hs
@@ -0,0 +1,9 @@
+module Model.Route
+  ( Route(..)
+  ) where
+
+data Route
+  = RootRoute
+  | IncomeRoute
+  | NotFoundRoute
+  deriving (Eq, Show)
diff --git a/client/src/Util/Css.hs b/client/src/Util/Css.hs
new file mode 100644
index 0000000..804b10f
--- /dev/null
+++ b/client/src/Util/Css.hs
@@ -0,0 +1,9 @@
+module Util.Css
+  ( classes
+  ) where
+
+import           Data.Text (Text)
+import qualified Data.Text as T
+
+classes :: [(Text, Bool)] -> Text
+classes = T.unwords . map fst . filter snd
diff --git a/client/src/Util/Router.hs b/client/src/Util/Router.hs
new file mode 100644
index 0000000..e9d0a1a
--- /dev/null
+++ b/client/src/Util/Router.hs
@@ -0,0 +1,266 @@
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE ConstraintKinds          #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE JavaScriptFFI            #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE OverloadedStrings        #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE RecursiveDo              #-}
+{-# LANGUAGE ScopedTypeVariables      #-}
+{-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE TypeFamilies             #-}
+
+module Util.Router (
+  -- == High-level routers
+    route
+  , route'
+  , partialPathRoute
+
+  -- = Low-level URL bar access
+  , getLoc
+  , getURI
+  , getUrlText
+  , uriOrigin
+  , URI
+
+  -- = History movement
+  , goForward
+  , goBack
+  ) where
+
+------------------------------------------------------------------------------
+import           Control.Lens                  ((&), (.~), (^.))
+import           Control.Monad.Fix             (MonadFix)
+import qualified Data.ByteString.Char8         as BS
+import           Data.Monoid                   ((<>))
+import           Data.Text                     (Text)
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as T
+import           GHCJS.DOM                     (currentDocumentUnchecked,
+                                                currentWindowUnchecked)
+import           GHCJS.DOM.Document            (createEvent)
+import           GHCJS.DOM.Event               (initEvent)
+import           GHCJS.DOM.EventM              (on)
+import           GHCJS.DOM.EventTarget         (dispatchEvent_)
+import           GHCJS.DOM.History             (History, back, forward,
+                                                pushState)
+import           GHCJS.DOM.Location            (getHref)
+import           GHCJS.DOM.PopStateEvent
+import           GHCJS.DOM.Types               (Location (..),
+                                                PopStateEvent (..))
+import           GHCJS.DOM.Types               (MonadJSM, uncheckedCastTo)
+import qualified GHCJS.DOM.Types               as DOM
+import           GHCJS.DOM.Window              (getHistory, getLocation)
+import           GHCJS.DOM.WindowEventHandlers (popState)
+import           GHCJS.Foreign                 (isFunction)
+import           GHCJS.Marshal.Pure            (pFromJSVal)
+import           Language.Javascript.JSaddle   (JSM, Object (..), ghcjsPure,
+                                                liftJSM)
+import qualified Language.Javascript.JSaddle   as JS
+import           Reflex.Dom.Core               hiding (EventName, Window)
+import qualified URI.ByteString                as U
+------------------------------------------------------------------------------
+
+
+-------------------------------------------------------------------------------
+-- | Manipulate and track the URL 'GHCJS.DOM.Types.Location' for dynamic
+--   routing of a widget
+--   These sources of URL-bar change will be reflected in the output URI
+--     - Input events to 'route'
+--     - Browser Forward/Back button clicks
+--     - forward/back javascript calls (or 'goForward'/'goBack') Haskell calls
+--     - Any URL changes followed by a popState event
+--   But external calls to pushState that don't manually fire a popState
+--   won't be detected
+route
+ :: forall t m.
+  ( MonadHold t m
+  , PostBuild t m
+  , TriggerEvent t m
+  , PerformEvent t m
+  , HasJSContext m
+  , HasJSContext (Performable m)
+  , MonadJSM m
+  , MonadJSM (Performable m))
+  => Event t T.Text
+  -> m (Dynamic t (U.URIRef U.Absolute))
+route pushTo = do
+  loc0    <- getURI
+
+  _ <- performEvent $ ffor pushTo $ \t -> do
+    let newState = Just t
+    withHistory $ \h -> pushState h (0 :: Double) ("" :: T.Text) (newState :: Maybe T.Text)
+    liftJSM dispatchEvent'
+
+  locUpdates <- getPopState
+  holdDyn loc0 locUpdates
+
+route'
+ :: forall t m a b.
+  ( MonadHold t m
+  , PostBuild t m
+  , TriggerEvent t m
+  , PerformEvent t m
+  , HasJSContext m
+  , HasJSContext (Performable m)
+  , MonadJSM m
+  , MonadJSM (Performable m)
+  , MonadFix m)
+  => (URI -> a -> URI)
+  -> (URI -> b)
+  -> Event t a
+  -> m (Dynamic t b)
+route' encode decode routeUpdate = do
+  rec rUri <- route (T.decodeUtf8 . U.serializeURIRef' <$> urlUpdates)
+      let urlUpdates = attachWith encode (current rUri) routeUpdate
+  return $ decode <$> rUri
+
+
+-------------------------------------------------------------------------------
+-- | Route a single page app according to the part of the path after
+--   pathBase
+partialPathRoute
+ :: forall t m.
+  ( MonadHold t m
+  , PostBuild t m
+  , DomBuilder t m
+  , TriggerEvent t m
+  , PerformEvent t m
+  , HasJSContext m
+  , HasJSContext (Performable m)
+  , MonadJSM m
+  , MonadJSM (Performable m)
+  , MonadFix m)
+  => T.Text  -- ^ The path segments not related to SPA routing
+             --   (leading '/' will be added automaticaly)
+  -> Event t T.Text -- ^ Updates to the path segments used for routing
+                    --   These values will be appended to the base path
+  -> m (Dynamic t [T.Text]) -- ^ Path segments used for routing
+partialPathRoute pathBase pathUpdates = do
+  route' (flip updateUrl) parseParts pathUpdates
+  where
+
+    rootPathBase :: T.Text
+    rootPathBase =
+      if T.null pathBase then
+        ""
+      else
+        "/" <> cleanT pathBase
+
+    toPath :: T.Text -> BS.ByteString
+    toPath dynpath = T.encodeUtf8 $ rootPathBase <> "/" <> cleanT dynpath
+
+    updateUrl :: T.Text -> URI -> URI
+    updateUrl updateParts u = u & U.pathL .~ toPath updateParts
+
+    parseParts :: URI -> [T.Text]
+    parseParts u =
+      maybe (error $ pfxErr u pathBase)
+            (T.splitOn "/" . T.decodeUtf8 . cleanB) .
+      BS.stripPrefix (T.encodeUtf8 $ cleanT pathBase) $
+      cleanB (u ^. U.pathL)
+
+    cleanT = T.dropWhile (=='/')
+    cleanB = BS.dropWhile (== '/')
+
+
+-------------------------------------------------------------------------------
+uriOrigin :: U.URIRef U.Absolute -> T.Text
+uriOrigin r = T.decodeUtf8 $ U.serializeURIRef' r'
+  where
+    r' = r { U.uriPath = mempty
+           , U.uriQuery = mempty
+           , U.uriFragment = mempty
+           }
+
+
+-------------------------------------------------------------------------------
+getPopState
+ :: forall t m.
+  ( MonadHold t m
+  , TriggerEvent t m
+  , MonadJSM m) => m (Event t URI)
+getPopState = do
+  window <- currentWindowUnchecked
+  wrapDomEventMaybe window (`on` popState) $ do
+    loc <- getLocation window
+    locStr <- getHref loc
+    return . hush $ U.parseURI U.laxURIParserOptions (T.encodeUtf8 locStr)
+
+
+-------------------------------------------------------------------------------
+goForward :: (HasJSContext m, MonadJSM m) => m ()
+goForward = withHistory forward
+
+
+-------------------------------------------------------------------------------
+goBack :: (HasJSContext m, MonadJSM m) => m ()
+goBack = withHistory back
+
+
+-------------------------------------------------------------------------------
+withHistory :: (HasJSContext m, MonadJSM m) => (History -> m a) -> m a
+withHistory act = do
+  w <- currentWindowUnchecked
+  h <- getHistory w
+  act h
+
+
+-------------------------------------------------------------------------------
+-- | (Unsafely) get the 'GHCJS.DOM.Location.Location' of a window
+getLoc :: (HasJSContext m, MonadJSM m) => m Location
+getLoc = do
+  win <- currentWindowUnchecked
+  loc <- getLocation win
+  return loc
+
+
+-------------------------------------------------------------------------------
+-- | (Unsafely) get the URL text of a window
+getUrlText :: (HasJSContext m, MonadJSM m) => m T.Text
+getUrlText = getLoc >>= getHref
+
+
+-------------------------------------------------------------------------------
+type URI = U.URIRef U.Absolute
+
+
+-------------------------------------------------------------------------------
+getURI :: (HasJSContext m, MonadJSM m) => m URI
+getURI = do
+  l <- getUrlText
+  return $ either (error "No parse of window location") id .
+    U.parseURI U.laxURIParserOptions $ T.encodeUtf8 l
+
+
+dispatchEvent' :: JSM ()
+dispatchEvent' = do
+  window <- currentWindowUnchecked
+  obj@(Object o) <- JS.create
+  JS.objSetPropertyByName obj ("cancelable" :: Text) True
+  JS.objSetPropertyByName obj ("bubbles" :: Text) True
+  JS.objSetPropertyByName obj ("view" :: Text) window
+  event <- JS.jsg ("PopStateEvent" :: Text) >>= ghcjsPure . isFunction >>= \case
+    True -> newPopStateEvent ("popstate" :: Text) $ Just $ pFromJSVal o
+    False -> do
+      doc <- currentDocumentUnchecked
+      event <- createEvent doc ("PopStateEvent" :: Text)
+      initEvent event ("popstate" :: Text) True True
+      JS.objSetPropertyByName obj ("view" :: Text) window
+      return $ uncheckedCastTo PopStateEvent event
+
+  dispatchEvent_ window event
+
+
+-------------------------------------------------------------------------------
+hush :: Either e a -> Maybe a
+hush (Right a) = Just a
+hush _         = Nothing
+
+
+-------------------------------------------------------------------------------
+pfxErr :: URI -> T.Text -> String
+pfxErr pn pathBase =
+  T.unpack $ "Encountered path (" <> T.decodeUtf8 (U.serializeURIRef' pn)
+            <> ") without expected prefix (" <> pathBase <> ")"
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 6435297..d853c7e 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,41 +2,84 @@ module View.App
   ( widget
   ) where
 
-import           Prelude      hiding (error, init)
-import qualified Reflex.Dom   as R
+import qualified Data.Text     as T
+import           Prelude       hiding (error, init)
+import           Reflex.Dom    (Dynamic, MonadWidget)
+import qualified Reflex.Dom    as R
 
-import           Common.Model (InitResult (..))
-import qualified Common.Msg   as Msg
+import           Common.Model  (Init, InitResult (..))
+import qualified Common.Msg    as Msg
 
-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
+import           Model.Route   (Route (..))
+import qualified Util.Router   as Router
+import           View.Header   (HeaderIn (..))
+import qualified View.Header   as Header
+import qualified View.NotFound as NotFound
+import           View.Payment  (PaymentIn (..))
+import qualified View.Payment  as Payment
+import qualified View.SignIn   as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
   R.mainWidget $ R.divClass "app" $ do
 
+    route <- getRoute
+
     headerOut <- Header.view $ HeaderIn
       { _headerIn_initResult = initResult
+      , _headerIn_isInitSuccess =
+        case initResult of
+          InitSuccess _ -> True
+          _             -> False
+      , _headerIn_route = route
       }
 
-    let signOut = Header._headerOut_signOut headerOut
+    let signOut =
+          Header._headerOut_signOut headerOut
+
+        mainContent =
+          case initResult of
+            InitSuccess init ->
+              signedWidget init route
+
+            InitEmpty ->
+              SignIn.view SignIn.EmptyMessage
 
-        initialContent = case initResult of
-          InitSuccess initSuccess -> do
-            _ <- Payment.widget $ PaymentIn
-              { _paymentIn_init = initSuccess
-              }
-            return ()
-          InitEmpty ->
-            SignIn.view SignIn.EmptyMessage
-          InitError error ->
-            SignIn.view (SignIn.ErrorMessage error)
+            InitError error ->
+              SignIn.view (SignIn.ErrorMessage error)
 
-        signOutContent = SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
+        signOutContent =
+          SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
 
-    _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+    _ <- R.widgetHold (mainContent) (signOutContent <$ signOut)
 
     R.blank
+
+signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
+signedWidget init route = do
+  R.dyn . R.ffor route $ \case
+    RootRoute ->
+      Payment.widget $ PaymentIn
+        { _paymentIn_init = init
+        }
+
+    IncomeRoute ->
+      R.el "div" $ R.text "Incomes"
+
+    NotFoundRoute ->
+      NotFound.view
+
+  return ()
+
+getRoute :: MonadWidget t m => m (Dynamic t Route)
+getRoute = do
+  r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never
+  return . R.ffor r $ \case
+    [""] ->
+      RootRoute
+
+    ["income"] ->
+      IncomeRoute
+
+    _ ->
+      NotFoundRoute
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 8f1fb78..9a4de89 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -4,40 +4,73 @@ module View.Header
   , HeaderOut(..)
   ) where
 
-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           Common.Model     (Init (..), InitResult (..), User (..))
-import qualified Common.Model     as CM
-import qualified Common.Msg       as Msg
-import qualified Component        as Component
-import           Component.Button (ButtonIn (..))
+import           Data.Map     (Map)
+import qualified Data.Map     as M
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Data.Time    (NominalDiffTime)
+import           Prelude      hiding (error, init)
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (Init (..), InitResult (..), User (..))
+import qualified Common.Model as CM
+import qualified Common.Msg   as Msg
+import           Component    (ButtonIn (..))
+import qualified Component    as Component
 import qualified Icon
+import           Model.Route  (Route (..))
+import qualified Util.Css     as CssUtil
+import qualified Util.Reflex  as ReflexUtil
 
-data HeaderIn = HeaderIn
-  { _headerIn_initResult :: InitResult
+data HeaderIn t = HeaderIn
+  { _headerIn_initResult    :: InitResult
+  , _headerIn_isInitSuccess :: Bool
+  , _headerIn_route         :: Dynamic t Route
   }
 
 data HeaderOut t = HeaderOut
   { _headerOut_signOut :: Event t ()
   }
 
-view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
+view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t)
 view headerIn =
   R.el "header" $ do
 
     R.divClass "title" $
       R.text $ Msg.get Msg.App_Title
 
-    signOut <- nameSignOut $ _headerIn_initResult headerIn
+    signOut <- R.el "div" $ do
+      rec
+        showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut)
+        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn)
+        signOut <- nameSignOut $ _headerIn_initResult headerIn
+      return signOut
 
     return $ HeaderOut
       { _headerOut_signOut = signOut
       }
 
+links :: forall t m. MonadWidget t m => Dynamic t Route -> m ()
+links route = do
+  Component.link
+    "/"
+    (R.ffor route (attrs RootRoute))
+    (Msg.get Msg.Payment_Title)
+
+  Component.link
+    "/income"
+    (R.ffor route (attrs IncomeRoute))
+    (Msg.get Msg.Income_Title)
+
+  where
+    attrs linkRoute currentRoute =
+      M.singleton "class" $
+        CssUtil.classes
+          [ ("item", True)
+          , ("current", linkRoute == currentRoute)
+          ]
+
 nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
 nameSignOut initResult = case initResult of
   (InitSuccess init) -> do
@@ -76,5 +109,5 @@ signOutButton = do
   where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
         askSignOut signOut =
           fmap getResult <$> R.performRequestAsync xhrRequest
-          where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
+          where xhrRequest = fmap (const $ R.postJson "/api/signOut" ()) signOut
                 getResult = (== 200) . R._xhrResponse_status
diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs
new file mode 100644
index 0000000..1d4e477
--- /dev/null
+++ b/client/src/View/NotFound.hs
@@ -0,0 +1,20 @@
+module View.NotFound
+  ( view
+  ) where
+
+import qualified Data.Map   as M
+import           Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import qualified Component  as Component
+
+view :: forall t m. MonadWidget t m => m ()
+view =
+  R.divClass "notfound" $ do
+    R.text (Msg.get Msg.NotFound_Message)
+
+    Component.link
+      "/"
+      (R.constDyn $ M.singleton "class" "link")
+      (Msg.get Msg.NotFound_LinkMessage)
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
index f2a5071..1072a5e 100644
--- a/client/src/View/Payment.hs
+++ b/client/src/View/Payment.hs
@@ -1,7 +1,6 @@
 module View.Payment
   ( widget
   , PaymentIn(..)
-  , PaymentOut(..)
   ) where
 
 import           Data.Text           (Text)
@@ -26,11 +25,7 @@ data PaymentIn = PaymentIn
   { _paymentIn_init :: Init
   }
 
-data PaymentOut = PaymentOut
-  {
-  }
-
-widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut
+widget :: forall t m. MonadWidget t m => PaymentIn -> m ()
 widget paymentIn = do
   R.elClass "main" "payment" $ do
     rec
@@ -86,7 +81,7 @@ widget paymentIn = do
             ]
         }
 
-    pure $ PaymentOut {}
+    pure ()
 
 debounceSearchName
   :: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index e7e319e..521c1a7 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -44,7 +44,7 @@ view input _ =
 
           let url =
                 R.ffor (_input_payment input) (\id ->
-                  T.concat ["/payment/", T.pack . show $ _payment_id id]
+                  T.concat ["/api/payment/", T.pack . show $ _payment_id id]
                 )
 
           (result, waiting) <- WaitFor.waitFor
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 187b64b..7819836 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -143,7 +143,7 @@ view input = do
                 })
 
             (addPayment, waiting) <- WaitFor.waitFor
-              (ajax "/payment")
+              (ajax "/api/payment")
               (ValidationUtil.fireValidation payment confirm)
 
           return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index f8b985f..8c248bd 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -50,7 +50,7 @@ view signInMessage =
         let form = SignInForm <$> _inputOut_raw input
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.postJson "/askSignIn")
+          (Ajax.postJson "/api/askSignIn")
           (ValidationUtil.fireMaybe
             ((\f -> f <$ SignInValidation.signIn f) <$> form)
             validate)
-- 
cgit v1.2.3


From 04c59f08f100ba6a0658d1f2b357f7d8b1e14218 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 13 Oct 2019 22:38:35 +0200
Subject: Show income table

---
 client/src/Component.hs            |   1 +
 client/src/Component/Table.hs      |  38 +++++++++
 client/src/View/App.hs             |  40 +++++-----
 client/src/View/Income/Income.hs   |  68 ++++++++++++++++
 client/src/View/Payment.hs         | 154 -------------------------------------
 client/src/View/Payment/Payment.hs | 154 +++++++++++++++++++++++++++++++++++++
 client/src/View/Payment/Table.hs   |   3 -
 7 files changed, 283 insertions(+), 175 deletions(-)
 create mode 100644 client/src/Component/Table.hs
 create mode 100644 client/src/View/Income/Income.hs
 delete mode 100644 client/src/View/Payment.hs
 create mode 100644 client/src/View/Payment/Payment.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index 7e0b151..97c250e 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -6,3 +6,4 @@ import           Component.Input  as X
 import           Component.Link   as X
 import           Component.Modal  as X
 import           Component.Select as X
+import           Component.Table  as X
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
new file mode 100644
index 0000000..a77a18d
--- /dev/null
+++ b/client/src/Component/Table.hs
@@ -0,0 +1,38 @@
+module Component.Table
+  ( table
+  , TableIn(..)
+  , TableOut(..)
+  ) where
+
+import           Data.Text  (Text)
+import           Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+data TableIn h r t = TableIn
+  { _tableIn_headerLabel :: h -> Text
+  , _tableIn_rows        :: Dynamic t [r]
+  , _tableIn_cell        :: h -> r -> Text
+  }
+
+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
+  R.divClass "table" $ do
+
+    R.divClass "lines" $ do
+      R.divClass "header" $ do
+        flip mapM_ [minBound..] $ \header ->
+          R.divClass "cell" . R.text $
+            _tableIn_headerLabel tableIn header
+
+      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)
+
+    return $ TableOut
+      {}
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index d853c7e..3292336 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,22 +2,24 @@ module View.App
   ( widget
   ) where
 
-import qualified Data.Text     as T
-import           Prelude       hiding (error, init)
-import           Reflex.Dom    (Dynamic, MonadWidget)
-import qualified Reflex.Dom    as R
-
-import           Common.Model  (Init, InitResult (..))
-import qualified Common.Msg    as Msg
-
-import           Model.Route   (Route (..))
-import qualified Util.Router   as Router
-import           View.Header   (HeaderIn (..))
-import qualified View.Header   as Header
-import qualified View.NotFound as NotFound
-import           View.Payment  (PaymentIn (..))
-import qualified View.Payment  as Payment
-import qualified View.SignIn   as SignIn
+import qualified Data.Text            as T
+import           Prelude              hiding (error, init)
+import           Reflex.Dom           (Dynamic, MonadWidget)
+import qualified Reflex.Dom           as R
+
+import           Common.Model         (Init, InitResult (..))
+import qualified Common.Msg           as Msg
+
+import           Model.Route          (Route (..))
+import qualified Util.Router          as Router
+import           View.Header          (HeaderIn (..))
+import qualified View.Header          as Header
+import           View.Income.Income   (IncomeIn (..))
+import qualified View.Income.Income   as Income
+import qualified View.NotFound        as NotFound
+import           View.Payment.Payment (PaymentIn (..))
+import qualified View.Payment.Payment as Payment
+import qualified View.SignIn          as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
@@ -59,12 +61,14 @@ signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
     RootRoute ->
-      Payment.widget $ PaymentIn
+      Payment.view $ PaymentIn
         { _paymentIn_init = init
         }
 
     IncomeRoute ->
-      R.el "div" $ R.text "Incomes"
+      Income.view $ IncomeIn
+        { _incomeIn_init = init
+        }
 
     NotFoundRoute ->
       NotFound.view
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
new file mode 100644
index 0000000..5e9ce1d
--- /dev/null
+++ b/client/src/View/Income/Income.hs
@@ -0,0 +1,68 @@
+module View.Income.Income
+  ( view
+  , IncomeIn(..)
+  ) where
+
+import qualified Data.List          as L
+import qualified Data.Maybe         as Maybe
+import           Data.Text          (Text)
+import qualified Data.Text          as T
+import           Reflex.Dom         (MonadWidget)
+import qualified Reflex.Dom         as R
+
+import           Common.Model       (Income (..), Init (..), User (..))
+import qualified Common.Model       as CM
+import qualified Common.Msg         as Msg
+import qualified Common.View.Format as Format
+import           Component          (TableIn (..))
+import qualified Component
+
+data IncomeIn = IncomeIn
+  { _incomeIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => IncomeIn -> m ()
+view incomeIn =
+  R.elClass "main" "income" $ do
+
+    R.divClass "withMargin" $
+      R.divClass "titleButton" $
+        R.el "h1" $
+          R.text $
+            Msg.get Msg.Income_MonthlyNet
+
+    Component.table $ TableIn
+      { _tableIn_headerLabel = headerLabel
+      , _tableIn_rows =
+        R.constDyn
+        . reverse
+        . L.sortOn _income_date
+        . _init_incomes
+        . _incomeIn_init
+        $ incomeIn
+      , _tableIn_cell = cell (_incomeIn_init incomeIn)
+      }
+    return ()
+
+data Header
+  = UserHeader
+  | AmountHeader
+  | DateHeader
+  deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel UserHeader   = Msg.get Msg.Income_Name
+headerLabel DateHeader   = Msg.get Msg.Income_Date
+headerLabel AmountHeader = Msg.get Msg.Income_Amount
+
+cell :: Init -> Header -> Income -> Text
+cell init header income =
+  case header of
+    UserHeader ->
+      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
+
+    DateHeader ->
+      Format.longDay . _income_date $ income
+
+    AmountHeader ->
+      Format.price (_init_currency init) . _income_amount $ income
diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs
deleted file mode 100644
index 1072a5e..0000000
--- a/client/src/View/Payment.hs
+++ /dev/null
@@ -1,154 +0,0 @@
-module View.Payment
-  ( widget
-  , PaymentIn(..)
-  ) where
-
-import           Data.Text           (Text)
-import qualified Data.Text           as T
-import           Data.Time.Clock     (NominalDiffTime)
-import           Prelude             hiding (init)
-import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom          as R
-
-import           Common.Model        (Frequency, Init (..), Payment (..),
-                                      PaymentCategory (..), PaymentId,
-                                      SavedPayment (..))
-import qualified Common.Util.Text    as T
-import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
-import qualified View.Payment.Header as Header
-import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
-import qualified View.Payment.Pages  as Pages
-import           View.Payment.Table  (TableIn (..), TableOut (..))
-import qualified View.Payment.Table  as Table
-
-data PaymentIn = PaymentIn
-  { _paymentIn_init :: Init
-  }
-
-widget :: forall t m. MonadWidget t m => PaymentIn -> m ()
-widget paymentIn = do
-  R.elClass "main" "payment" $ do
-    rec
-      let init = _paymentIn_init paymentIn
-
-          paymentsPerPage = 7
-
-          addPayment = R.leftmost
-            [ _headerOut_addPayment header
-            , _tableOut_addPayment table
-            ]
-
-      payments <- reducePayments
-        (_init_payments init)
-        (_savedPayment_payment <$> addPayment)
-        (_savedPayment_payment <$> _tableOut_editPayment table)
-        (_tableOut_deletePayment table)
-
-      paymentCategories <- reducePaymentCategories
-        (_init_paymentCategories init)
-        payments
-        (_savedPayment_paymentCategory <$> addPayment)
-        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
-        (_tableOut_deletePayment table)
-
-      (searchNameEvent, searchName) <-
-        debounceSearchName (_headerOut_searchName header)
-
-      let searchPayments =
-            getSearchPayments searchName (_headerOut_searchFrequency header) payments
-
-      header <- Header.widget $ HeaderIn
-        { _headerIn_init = init
-        , _headerIn_payments = payments
-        , _headerIn_searchPayments = searchPayments
-        , _headerIn_paymentCategories = paymentCategories
-        }
-
-      table <- Table.widget $ TableIn
-        { _tableIn_init = init
-        , _tableIn_currentPage = _pagesOut_currentPage pages
-        , _tableIn_payments = searchPayments
-        , _tableIn_perPage = paymentsPerPage
-        , _tableIn_paymentCategories = paymentCategories
-        }
-
-      pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> searchPayments
-        , _pagesIn_perPage = paymentsPerPage
-        , _pagesIn_reset = R.leftmost $
-            [ () <$ searchNameEvent
-            , () <$ _headerOut_addPayment header
-            ]
-        }
-
-    pure ()
-
-debounceSearchName
-  :: forall t m. MonadWidget t m
-  => Dynamic t Text
-  -> m (Event t Text, Dynamic t Text)
-debounceSearchName searchName = do
-  event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
-  dynamic <- R.holdDyn "" event
-  return (event, dynamic)
-
-reducePayments
-  :: forall t m. MonadWidget t m
-  => [Payment]
-  -> Event t Payment -- add payment
-  -> Event t Payment -- edit payment
-  -> Event t Payment -- delete payment
-  -> m (Dynamic t [Payment])
-reducePayments initPayments addPayment editPayment deletePayment =
-  R.foldDyn id initPayments $ R.leftmost
-    [ (:) <$> addPayment
-    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
-    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
-    ]
-
-reducePaymentCategories
-  :: forall t m. MonadWidget t m
-  => [PaymentCategory]
-  -> Dynamic t [Payment]      -- payments
-  -> Event t PaymentCategory  -- add payment category
-  -> Event t PaymentCategory  -- edit payment category
-  -> Event t Payment          -- delete payment
-  -> m (Dynamic t [PaymentCategory])
-reducePaymentCategories
-  initPaymentCategories
-  payments
-  addPaymentCategory
-  editPaymentCategory
-  deletePayment
-    =
-  R.foldDyn id initPaymentCategories $ R.leftmost
-    [ (:) <$> addPaymentCategory
-    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
-    , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
-    ]
-  where
-    deletePaymentName =
-      R.attachWithMaybe
-        (\ps p ->
-          if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
-            Nothing
-          else
-            Just (_payment_name p))
-        (R.current payments)
-        deletePayment
-    lowerName = T.toLower . _payment_name
-
-getSearchPayments
-  :: forall t. Reflex t
-  => Dynamic t Text
-  -> Dynamic t Frequency
-  -> Dynamic t [Payment]
-  -> Dynamic t [Payment]
-getSearchPayments name frequency payments = do
-  n <- name
-  f <- frequency
-  ps <- payments
-  pure $ flip filter ps (\p ->
-    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
-    && (_payment_frequency p == f)
-    ))
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
new file mode 100644
index 0000000..cfdb441
--- /dev/null
+++ b/client/src/View/Payment/Payment.hs
@@ -0,0 +1,154 @@
+module View.Payment.Payment
+  ( view
+  , PaymentIn(..)
+  ) where
+
+import           Data.Text           (Text)
+import qualified Data.Text           as T
+import           Data.Time.Clock     (NominalDiffTime)
+import           Prelude             hiding (init)
+import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom          as R
+
+import           Common.Model        (Frequency, Init (..), Payment (..),
+                                      PaymentCategory (..), PaymentId,
+                                      SavedPayment (..))
+import qualified Common.Util.Text    as T
+import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
+import qualified View.Payment.Header as Header
+import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
+import qualified View.Payment.Pages  as Pages
+import           View.Payment.Table  (TableIn (..), TableOut (..))
+import qualified View.Payment.Table  as Table
+
+data PaymentIn = PaymentIn
+  { _paymentIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => PaymentIn -> m ()
+view paymentIn = do
+  R.elClass "main" "payment" $ do
+    rec
+      let init = _paymentIn_init paymentIn
+
+          paymentsPerPage = 7
+
+          addPayment = R.leftmost
+            [ _headerOut_addPayment header
+            , _tableOut_addPayment table
+            ]
+
+      payments <- reducePayments
+        (_init_payments init)
+        (_savedPayment_payment <$> addPayment)
+        (_savedPayment_payment <$> _tableOut_editPayment table)
+        (_tableOut_deletePayment table)
+
+      paymentCategories <- reducePaymentCategories
+        (_init_paymentCategories init)
+        payments
+        (_savedPayment_paymentCategory <$> addPayment)
+        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
+        (_tableOut_deletePayment table)
+
+      (searchNameEvent, searchName) <-
+        debounceSearchName (_headerOut_searchName header)
+
+      let searchPayments =
+            getSearchPayments searchName (_headerOut_searchFrequency header) payments
+
+      header <- Header.widget $ HeaderIn
+        { _headerIn_init = init
+        , _headerIn_payments = payments
+        , _headerIn_searchPayments = searchPayments
+        , _headerIn_paymentCategories = paymentCategories
+        }
+
+      table <- Table.widget $ TableIn
+        { _tableIn_init = init
+        , _tableIn_currentPage = _pagesOut_currentPage pages
+        , _tableIn_payments = searchPayments
+        , _tableIn_perPage = paymentsPerPage
+        , _tableIn_paymentCategories = paymentCategories
+        }
+
+      pages <- Pages.widget $ PagesIn
+        { _pagesIn_total = length <$> searchPayments
+        , _pagesIn_perPage = paymentsPerPage
+        , _pagesIn_reset = R.leftmost $
+            [ () <$ searchNameEvent
+            , () <$ _headerOut_addPayment header
+            ]
+        }
+
+    pure ()
+
+debounceSearchName
+  :: forall t m. MonadWidget t m
+  => Dynamic t Text
+  -> m (Event t Text, Dynamic t Text)
+debounceSearchName searchName = do
+  event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
+  dynamic <- R.holdDyn "" event
+  return (event, dynamic)
+
+reducePayments
+  :: forall t m. MonadWidget t m
+  => [Payment]
+  -> Event t Payment -- add payment
+  -> Event t Payment -- edit payment
+  -> Event t Payment -- delete payment
+  -> m (Dynamic t [Payment])
+reducePayments initPayments addPayment editPayment deletePayment =
+  R.foldDyn id initPayments $ R.leftmost
+    [ (:) <$> addPayment
+    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
+    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
+    ]
+
+reducePaymentCategories
+  :: forall t m. MonadWidget t m
+  => [PaymentCategory]
+  -> Dynamic t [Payment]      -- payments
+  -> Event t PaymentCategory  -- add payment category
+  -> Event t PaymentCategory  -- edit payment category
+  -> Event t Payment          -- delete payment
+  -> m (Dynamic t [PaymentCategory])
+reducePaymentCategories
+  initPaymentCategories
+  payments
+  addPaymentCategory
+  editPaymentCategory
+  deletePayment
+    =
+  R.foldDyn id initPaymentCategories $ R.leftmost
+    [ (:) <$> addPaymentCategory
+    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
+    , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
+    ]
+  where
+    deletePaymentName =
+      R.attachWithMaybe
+        (\ps p ->
+          if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
+            Nothing
+          else
+            Just (_payment_name p))
+        (R.current payments)
+        deletePayment
+    lowerName = T.toLower . _payment_name
+
+getSearchPayments
+  :: forall t. Reflex t
+  => Dynamic t Text
+  -> Dynamic t Frequency
+  -> Dynamic t [Payment]
+  -> Dynamic t [Payment]
+getSearchPayments name frequency payments = do
+  n <- name
+  f <- frequency
+  ps <- payments
+  pure $ flip filter ps (\p ->
+    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
+    && (_payment_frequency p == f)
+    ))
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 40bc864..bf6b604 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -30,9 +30,6 @@ import qualified View.Payment.Edit   as Edit
 import qualified Icon
 import qualified Util.Reflex         as ReflexUtil
 
--- TODO: remove
-import           Debug.Trace         (trace)
-
 data TableIn t = TableIn
   { _tableIn_init              :: Init
   , _tableIn_currentPage       :: Dynamic t Int
-- 
cgit v1.2.3


From 284214d3af39143fdbeca57ffa4864389e7d517a Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 14 Oct 2019 09:10:33 +0200
Subject: Show cumulative incomes per user in income page

---
 client/src/Util/Date.hs          | 12 +++++++
 client/src/View/Income/Income.hs | 71 ++++++++++++++++++++++++++++++----------
 2 files changed, 66 insertions(+), 17 deletions(-)
 create mode 100644 client/src/Util/Date.hs

(limited to 'client/src')

diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs
new file mode 100644
index 0000000..8fad881
--- /dev/null
+++ b/client/src/Util/Date.hs
@@ -0,0 +1,12 @@
+module Util.Date
+  ( utcToLocalDay
+  ) where
+
+import           Data.Time.Calendar  (Day)
+import           Data.Time.Clock     (UTCTime)
+import qualified Data.Time.LocalTime as LocalTime
+
+utcToLocalDay :: UTCTime -> IO Day
+utcToLocalDay time = do
+  timezone <- LocalTime.getCurrentTimeZone
+  return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 5e9ce1d..d0c0a45 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -3,19 +3,22 @@ module View.Income.Income
   , IncomeIn(..)
   ) where
 
-import qualified Data.List          as L
-import qualified Data.Maybe         as Maybe
-import           Data.Text          (Text)
-import qualified Data.Text          as T
-import           Reflex.Dom         (MonadWidget)
-import qualified Reflex.Dom         as R
-
-import           Common.Model       (Income (..), Init (..), User (..))
-import qualified Common.Model       as CM
-import qualified Common.Msg         as Msg
-import qualified Common.View.Format as Format
-import           Component          (TableIn (..))
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.List              as L
+import qualified Data.Maybe             as Maybe
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Clock
+import           Reflex.Dom             (MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Income (..), Init (..), User (..))
+import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
+import qualified Common.View.Format     as Format
+import           Component              (TableIn (..))
 import qualified Component
+import qualified Util.Date              as DateUtil
 
 data IncomeIn = IncomeIn
   { _incomeIn_init :: Init
@@ -25,11 +28,7 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m ()
 view incomeIn =
   R.elClass "main" "income" $ do
 
-    R.divClass "withMargin" $
-      R.divClass "titleButton" $
-        R.el "h1" $
-          R.text $
-            Msg.get Msg.Income_MonthlyNet
+    header (_incomeIn_init incomeIn)
 
     Component.table $ TableIn
       { _tableIn_headerLabel = headerLabel
@@ -42,8 +41,46 @@ view incomeIn =
         $ incomeIn
       , _tableIn_cell = cell (_incomeIn_init incomeIn)
       }
+
     return ()
 
+header :: forall t m. MonadWidget t m => Init -> m ()
+header init =
+  R.divClass "withMargin" $ do
+
+    currentTime <- liftIO Clock.getCurrentTime
+
+    Maybe.fromMaybe R.blank $
+      flip fmap useIncomesFrom $ \since ->
+        R.el "div" $ do
+
+          R.el "h1" $ do
+            day <- liftIO $ DateUtil.utcToLocalDay since
+            R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day))
+
+          R.el "ul" $
+            flip mapM_ (_init_users init) $ \user ->
+              R.el "li" $
+                R.text $ do
+                  let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init)
+                  T.intercalate " "
+                    [ _user_name user
+                    , "−"
+                    , Format.price (_init_currency init) $
+                      CM.cumulativeIncomesSince currentTime since incomes
+                    ]
+
+    R.divClass "titleButton" $
+      R.el "h1" $
+        R.text $
+          Msg.get Msg.Income_MonthlyNet
+
+  where
+    useIncomesFrom = CM.useIncomesFrom
+      (map _user_id $_init_users init)
+      (_init_incomes init)
+      (_init_payments init)
+
 data Header
   = UserHeader
   | AmountHeader
-- 
cgit v1.2.3


From 0b40b6b5583b5c437f83e61bf8913f2b4c447b24 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 19 Oct 2019 09:36:03 +0200
Subject: Include pages into table component

---
 client/src/Component.hs          |  1 +
 client/src/Component/Pages.hs    | 88 ++++++++++++++++++++++++++++++++++++++++
 client/src/Component/Table.hs    | 53 +++++++++++++++++-------
 client/src/View/Income/Income.hs |  2 +
 4 files changed, 129 insertions(+), 15 deletions(-)
 create mode 100644 client/src/Component/Pages.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index 97c250e..4c51750 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -5,5 +5,6 @@ import           Component.Form   as X
 import           Component.Input  as X
 import           Component.Link   as X
 import           Component.Modal  as X
+import           Component.Pages  as X
 import           Component.Select as X
 import           Component.Table  as X
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)
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index d0c0a45..0fdd7d3 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -40,6 +40,8 @@ view incomeIn =
         . _incomeIn_init
         $ incomeIn
       , _tableIn_cell = cell (_incomeIn_init incomeIn)
+      , _tableIn_perPage = 7
+      , _tableIn_resetPage = R.never
       }
 
     return ()
-- 
cgit v1.2.3


From 6e9e34e92a244ab6c38d135d46f9f5bb01391906 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 09:51:52 +0200
Subject: Move income header and income table views into separate components

---
 client/src/View/Income/Header.hs |  60 +++++++++++++++++++++++
 client/src/View/Income/Income.hs | 100 +++++----------------------------------
 client/src/View/Income/Table.hs  |  63 ++++++++++++++++++++++++
 3 files changed, 135 insertions(+), 88 deletions(-)
 create mode 100644 client/src/View/Income/Header.hs
 create mode 100644 client/src/View/Income/Table.hs

(limited to 'client/src')

diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
new file mode 100644
index 0000000..b7170c9
--- /dev/null
+++ b/client/src/View/Income/Header.hs
@@ -0,0 +1,60 @@
+module View.Income.Header
+  ( view
+  , HeaderIn(..)
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Maybe             as Maybe
+import qualified Data.Text              as T
+import qualified Data.Time.Clock        as Clock
+import           Reflex.Dom             (MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Income (..), Init (..), User (..))
+import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
+import qualified Common.View.Format     as Format
+import qualified Util.Date              as DateUtil
+
+data HeaderIn = HeaderIn
+  { _headerIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => HeaderIn -> m ()
+view headerIn =
+  R.divClass "withMargin" $ do
+
+    currentTime <- liftIO Clock.getCurrentTime
+
+    Maybe.fromMaybe R.blank $
+      flip fmap useIncomesFrom $ \since ->
+        R.el "div" $ do
+
+          R.el "h1" $ do
+            day <- liftIO $ DateUtil.utcToLocalDay since
+            R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day))
+
+          R.el "ul" $
+            flip mapM_ (_init_users init) $ \user ->
+              R.el "li" $
+                R.text $ do
+                  let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init)
+                  T.intercalate " "
+                    [ _user_name user
+                    , "−"
+                    , Format.price (_init_currency init) $
+                      CM.cumulativeIncomesSince currentTime since incomes
+                    ]
+
+    R.divClass "titleButton" $
+      R.el "h1" $
+        R.text $
+          Msg.get Msg.Income_MonthlyNet
+
+  where
+    init = _headerIn_init headerIn
+
+    useIncomesFrom = CM.useIncomesFrom
+      (map _user_id $_init_users init)
+      (_init_incomes init)
+      (_init_payments init)
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 0fdd7d3..b0c6f0b 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -3,22 +3,14 @@ module View.Income.Income
   , IncomeIn(..)
   ) where
 
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.List              as L
-import qualified Data.Maybe             as Maybe
-import           Data.Text              (Text)
-import qualified Data.Text              as T
-import qualified Data.Time.Clock        as Clock
-import           Reflex.Dom             (MonadWidget)
-import qualified Reflex.Dom             as R
+import           Reflex.Dom         (MonadWidget)
+import qualified Reflex.Dom         as R
 
-import           Common.Model           (Income (..), Init (..), User (..))
-import qualified Common.Model           as CM
-import qualified Common.Msg             as Msg
-import qualified Common.View.Format     as Format
-import           Component              (TableIn (..))
-import qualified Component
-import qualified Util.Date              as DateUtil
+import           Common.Model       (Init)
+import           View.Income.Header (HeaderIn (..))
+import qualified View.Income.Header as Header
+import           View.Income.Table  (IncomeTableIn (..))
+import qualified View.Income.Table  as Table
 
 data IncomeIn = IncomeIn
   { _incomeIn_init :: Init
@@ -28,80 +20,12 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m ()
 view incomeIn =
   R.elClass "main" "income" $ do
 
-    header (_incomeIn_init incomeIn)
+    Header.view $ HeaderIn
+      { _headerIn_init = _incomeIn_init incomeIn
+      }
 
-    Component.table $ TableIn
-      { _tableIn_headerLabel = headerLabel
-      , _tableIn_rows =
-        R.constDyn
-        . reverse
-        . L.sortOn _income_date
-        . _init_incomes
-        . _incomeIn_init
-        $ incomeIn
-      , _tableIn_cell = cell (_incomeIn_init incomeIn)
-      , _tableIn_perPage = 7
-      , _tableIn_resetPage = R.never
+    Table.view $ IncomeTableIn
+      { _tableIn_init = _incomeIn_init incomeIn
       }
 
     return ()
-
-header :: forall t m. MonadWidget t m => Init -> m ()
-header init =
-  R.divClass "withMargin" $ do
-
-    currentTime <- liftIO Clock.getCurrentTime
-
-    Maybe.fromMaybe R.blank $
-      flip fmap useIncomesFrom $ \since ->
-        R.el "div" $ do
-
-          R.el "h1" $ do
-            day <- liftIO $ DateUtil.utcToLocalDay since
-            R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day))
-
-          R.el "ul" $
-            flip mapM_ (_init_users init) $ \user ->
-              R.el "li" $
-                R.text $ do
-                  let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init)
-                  T.intercalate " "
-                    [ _user_name user
-                    , "−"
-                    , Format.price (_init_currency init) $
-                      CM.cumulativeIncomesSince currentTime since incomes
-                    ]
-
-    R.divClass "titleButton" $
-      R.el "h1" $
-        R.text $
-          Msg.get Msg.Income_MonthlyNet
-
-  where
-    useIncomesFrom = CM.useIncomesFrom
-      (map _user_id $_init_users init)
-      (_init_incomes init)
-      (_init_payments init)
-
-data Header
-  = UserHeader
-  | AmountHeader
-  | DateHeader
-  deriving (Eq, Show, Bounded, Enum)
-
-headerLabel :: Header -> Text
-headerLabel UserHeader   = Msg.get Msg.Income_Name
-headerLabel DateHeader   = Msg.get Msg.Income_Date
-headerLabel AmountHeader = Msg.get Msg.Income_Amount
-
-cell :: Init -> Header -> Income -> Text
-cell init header income =
-  case header of
-    UserHeader ->
-      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
-
-    DateHeader ->
-      Format.longDay . _income_date $ income
-
-    AmountHeader ->
-      Format.price (_init_currency init) . _income_amount $ income
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
new file mode 100644
index 0000000..2e8f4e6
--- /dev/null
+++ b/client/src/View/Income/Table.hs
@@ -0,0 +1,63 @@
+module View.Income.Table
+  ( view
+  , IncomeTableIn(..)
+  ) where
+
+import qualified Data.List          as L
+import qualified Data.Maybe         as Maybe
+import           Data.Text          (Text)
+import           Reflex.Dom         (MonadWidget)
+import qualified Reflex.Dom         as R
+
+import           Common.Model       (Income (..), Init (..), User (..))
+import qualified Common.Model       as CM
+import qualified Common.Msg         as Msg
+import qualified Common.View.Format as Format
+import           Component          (TableIn (..))
+import qualified Component
+
+data IncomeTableIn = IncomeTableIn
+  { _tableIn_init :: Init
+  }
+
+view :: forall t m. MonadWidget t m => IncomeTableIn -> m ()
+view tableIn = do
+
+    Component.table $ TableIn
+      { _tableIn_headerLabel = headerLabel
+      , _tableIn_rows =
+        R.constDyn
+        . reverse
+        . L.sortOn _income_date
+        . _init_incomes
+        . _tableIn_init
+        $ tableIn
+      , _tableIn_cell = cell (_tableIn_init tableIn)
+      , _tableIn_perPage = 7
+      , _tableIn_resetPage = R.never
+      }
+
+    return ()
+
+data Header
+  = UserHeader
+  | AmountHeader
+  | DateHeader
+  deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel UserHeader   = Msg.get Msg.Income_Name
+headerLabel DateHeader   = Msg.get Msg.Income_Date
+headerLabel AmountHeader = Msg.get Msg.Income_Amount
+
+cell :: Init -> Header -> Income -> Text
+cell init header income =
+  case header of
+    UserHeader ->
+      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
+
+    DateHeader ->
+      Format.longDay . _income_date $ income
+
+    AmountHeader ->
+      Format.price (_init_currency init) . _income_amount $ income
-- 
cgit v1.2.3


From 7aadcc97f9df0e2daccbe8a8726d8bc6c63d67f4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 12:02:21 +0200
Subject: Add income

---
 client/src/Component.hs           |   1 -
 client/src/View/Income/Add.hs     |  36 ++++++++++++
 client/src/View/Income/Form.hs    | 113 ++++++++++++++++++++++++++++++++++++++
 client/src/View/Income/Header.hs  |  55 ++++++++++++++-----
 client/src/View/Income/Income.hs  |  21 +++++--
 client/src/View/Income/Table.hs   |  17 ++----
 client/src/View/Payment/Delete.hs |   1 +
 client/src/View/Payment/Header.hs |  14 ++---
 8 files changed, 219 insertions(+), 39 deletions(-)
 create mode 100644 client/src/View/Income/Add.hs
 create mode 100644 client/src/View/Income/Form.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index 4c51750..b715a83 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -4,7 +4,6 @@ import           Component.Button as X
 import           Component.Form   as X
 import           Component.Input  as X
 import           Component.Link   as X
-import           Component.Modal  as X
 import           Component.Pages  as X
 import           Component.Select as X
 import           Component.Table  as X
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
new file mode 100644
index 0000000..d83bb51
--- /dev/null
+++ b/client/src/View/Income/Add.hs
@@ -0,0 +1,36 @@
+module View.Income.Add
+  ( view
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Time.Clock        as Time
+import           Reflex.Dom             (MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (CreateIncomeForm (..), Income)
+import qualified Common.Msg             as Msg
+import qualified Common.Util.Time       as TimeUtil
+import qualified Component.Modal        as Modal
+import qualified Util.Reflex            as ReflexUtil
+import           View.Income.Form       (FormIn (..), FormOut (..))
+import qualified View.Income.Form       as Form
+
+view :: forall t m. MonadWidget t m => Modal.Content t m Income
+view cancel = do
+
+  currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+  form <- R.dyn $
+    return $ Form.view $ FormIn
+      { _formIn_cancel = cancel
+      , _formIn_headerLabel = Msg.get Msg.Income_AddLong
+      , _formIn_amount = ""
+      , _formIn_date = currentDay
+      , _formIn_mkPayload = CreateIncomeForm
+      , _formIn_httpMethod = Form.Post
+      }
+
+  hide <- ReflexUtil.flatten (_formOut_hide <$> form)
+  addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form)
+
+  return (hide, addIncome)
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
new file mode 100644
index 0000000..b8a9094
--- /dev/null
+++ b/client/src/View/Income/Form.hs
@@ -0,0 +1,113 @@
+module View.Income.Form
+  ( view
+  , FormIn(..)
+  , HttpMethod(..)
+  , FormOut(..)
+  ) where
+
+import           Data.Aeson               (ToJSON)
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time.Calendar       (Day)
+import qualified Data.Time.Calendar       as Calendar
+import qualified Data.Validation          as V
+import           Reflex.Dom               (Event, MonadWidget)
+import qualified Reflex.Dom               as R
+
+import           Common.Model             (Income)
+import qualified Common.Msg               as Msg
+import qualified Common.Validation.Income as IncomeValidation
+import           Component                (ButtonIn (..), InputIn (..),
+                                           InputOut (..))
+import qualified Component                as Component
+import qualified Util.Ajax                as Ajax
+import qualified Util.Either              as EitherUtil
+import qualified Util.Validation          as ValidationUtil
+import qualified Util.WaitFor             as WaitFor
+
+data FormIn t i = FormIn
+  { _formIn_cancel      :: Event t ()
+  , _formIn_headerLabel :: Text
+  , _formIn_amount      :: Text
+  , _formIn_date        :: Day
+  , _formIn_mkPayload   :: Text -> Text -> i
+  , _formIn_httpMethod  :: HttpMethod
+  }
+
+data HttpMethod = Put | Post
+
+data FormOut t = FormOut
+  { _formOut_hide      :: Event t ()
+  , _formOut_addIncome :: Event t Income
+  }
+
+view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t)
+view formIn = do
+  R.divClass "form" $ do
+    R.divClass "formHeader" $
+      R.text (_formIn_headerLabel formIn)
+
+    R.divClass "formContent" $ do
+      rec
+        let reset = R.leftmost
+              [ "" <$ cancel
+              , "" <$ addIncome
+              , "" <$ _formIn_cancel formIn
+              ]
+
+        amount <- _inputOut_raw <$> (Component.input
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Income_Amount
+            , _inputIn_initialValue = _formIn_amount formIn
+            , _inputIn_validation = IncomeValidation.amount
+            })
+          (_formIn_amount formIn <$ reset)
+          confirm)
+
+        let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
+
+        date <- _inputOut_raw <$> (Component.input
+          (Component.defaultInputIn
+            { _inputIn_label = Msg.get Msg.Income_Date
+            , _inputIn_initialValue = initialDate
+            , _inputIn_inputType = "date"
+            , _inputIn_hasResetButton = False
+            , _inputIn_validation = IncomeValidation.date
+            })
+          (initialDate <$ reset)
+          confirm)
+
+        let income = do
+              a <- amount
+              d <- date
+              return . V.Success $ (_formIn_mkPayload formIn) a d
+
+        (addIncome, cancel, confirm) <- R.divClass "buttons" $ do
+          rec
+            cancel <- Component._buttonOut_clic <$> (Component.button $
+              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+                { _buttonIn_class = R.constDyn "undo" })
+
+            confirm <- Component._buttonOut_clic <$> (Component.button $
+              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+                { _buttonIn_class = R.constDyn "confirm"
+                , _buttonIn_waiting = waiting
+                , _buttonIn_submit = True
+                })
+
+            (addIncome, waiting) <- WaitFor.waitFor
+              (ajax "/api/income")
+              (ValidationUtil.fireValidation income confirm)
+
+          return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm)
+
+      return FormOut
+        { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ]
+        , _formOut_addIncome = addIncome
+        }
+
+  where
+    ajax =
+      case _formIn_httpMethod formIn of
+        Post -> Ajax.postJson
+        Put  -> Ajax.putJson
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index b7170c9..e384161 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -1,33 +1,46 @@
 module View.Income.Header
   ( view
   , HeaderIn(..)
+  , HeaderOut(..)
   ) where
 
 import           Control.Monad.IO.Class (liftIO)
 import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
 import qualified Data.Time.Clock        as Clock
-import           Reflex.Dom             (MonadWidget)
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
 import           Common.Model           (Income (..), Init (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
+import           Component              (ButtonOut (..))
+import qualified Component
+import qualified Component.Modal        as Modal
 import qualified Util.Date              as DateUtil
+import qualified View.Income.Add        as Add
 
-data HeaderIn = HeaderIn
-  { _headerIn_init :: Init
+data HeaderIn t = HeaderIn
+  { _headerIn_init    :: Init
+  , _headerIn_incomes :: Dynamic t [Income]
   }
 
-view :: forall t m. MonadWidget t m => HeaderIn -> m ()
+data HeaderOut t = HeaderOut
+  { _headerOut_addIncome :: Event t Income
+  }
+
+view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
 view headerIn =
   R.divClass "withMargin" $ do
 
     currentTime <- liftIO Clock.getCurrentTime
 
-    Maybe.fromMaybe R.blank $
-      flip fmap useIncomesFrom $ \since ->
+    R.dyn . R.ffor useIncomesFrom $ \case
+      (Nothing, _) ->
+        R.blank
+
+      (Just since, incomes) ->
         R.el "div" $ do
 
           R.el "h1" $ do
@@ -38,23 +51,39 @@ view headerIn =
             flip mapM_ (_init_users init) $ \user ->
               R.el "li" $
                 R.text $ do
-                  let incomes = filter ((==) (_user_id user) . _income_userId) (_init_incomes init)
+                  let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes
                   T.intercalate " "
                     [ _user_name user
                     , "−"
                     , Format.price (_init_currency init) $
-                      CM.cumulativeIncomesSince currentTime since incomes
+                      CM.cumulativeIncomesSince currentTime since userIncomes
                     ]
 
-    R.divClass "titleButton" $
+    R.divClass "titleButton" $ do
       R.el "h1" $
         R.text $
           Msg.get Msg.Income_MonthlyNet
 
+      addIncome <- _buttonOut_clic <$>
+        (Component.button . Component.defaultButtonIn . R.text $
+          Msg.get Msg.Income_AddLong)
+
+      addIncome <- Modal.view $ Modal.Input
+        { Modal._input_show    = addIncome
+        , Modal._input_content = Add.view
+        }
+
+      return $ HeaderOut
+        { _headerOut_addIncome = addIncome
+        }
+
   where
     init = _headerIn_init headerIn
 
-    useIncomesFrom = CM.useIncomesFrom
-      (map _user_id $_init_users init)
-      (_init_incomes init)
-      (_init_payments init)
+    useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes ->
+      ( CM.useIncomesFrom
+        (map _user_id $_init_users init)
+        incomes
+        (_init_payments init)
+      , incomes
+      )
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index b0c6f0b..167aedf 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -3,11 +3,11 @@ module View.Income.Income
   , IncomeIn(..)
   ) where
 
-import           Reflex.Dom         (MonadWidget)
+import           Reflex.Dom         (Dynamic, MonadWidget)
 import qualified Reflex.Dom         as R
 
-import           Common.Model       (Init)
-import           View.Income.Header (HeaderIn (..))
+import           Common.Model       (Init (..))
+import           View.Income.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Income.Header as Header
 import           View.Income.Table  (IncomeTableIn (..))
 import qualified View.Income.Table  as Table
@@ -20,12 +20,21 @@ view :: forall t m. MonadWidget t m => IncomeIn -> m ()
 view incomeIn =
   R.elClass "main" "income" $ do
 
-    Header.view $ HeaderIn
-      { _headerIn_init = _incomeIn_init incomeIn
-      }
+    rec
+
+      incomes <- R.foldDyn
+        (:)
+        (_init_incomes . _incomeIn_init $ incomeIn)
+        (_headerOut_addIncome header)
+
+      header <- Header.view $ HeaderIn
+        { _headerIn_init = _incomeIn_init incomeIn
+        , _headerIn_incomes = incomes
+        }
 
     Table.view $ IncomeTableIn
       { _tableIn_init = _incomeIn_init incomeIn
+      , _tableIn_incomes = incomes
       }
 
     return ()
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 2e8f4e6..5363ca5 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -6,7 +6,7 @@ module View.Income.Table
 import qualified Data.List          as L
 import qualified Data.Maybe         as Maybe
 import           Data.Text          (Text)
-import           Reflex.Dom         (MonadWidget)
+import           Reflex.Dom         (Dynamic, MonadWidget)
 import qualified Reflex.Dom         as R
 
 import           Common.Model       (Income (..), Init (..), User (..))
@@ -16,22 +16,17 @@ import qualified Common.View.Format as Format
 import           Component          (TableIn (..))
 import qualified Component
 
-data IncomeTableIn = IncomeTableIn
-  { _tableIn_init :: Init
+data IncomeTableIn t = IncomeTableIn
+  { _tableIn_init    :: Init
+  , _tableIn_incomes :: Dynamic t [Income]
   }
 
-view :: forall t m. MonadWidget t m => IncomeTableIn -> m ()
+view :: forall t m. MonadWidget t m => IncomeTableIn t -> m ()
 view tableIn = do
 
     Component.table $ TableIn
       { _tableIn_headerLabel = headerLabel
-      , _tableIn_rows =
-        R.constDyn
-        . reverse
-        . L.sortOn _income_date
-        . _init_incomes
-        . _tableIn_init
-        $ tableIn
+      , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date
       , _tableIn_cell = cell (_tableIn_init tableIn)
       , _tableIn_perPage = 7
       , _tableIn_resetPage = R.never
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 521c1a7..dc7e395 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -13,6 +13,7 @@ import qualified Common.Msg      as Msg
 import           Component       (ButtonIn (..), ButtonOut (..))
 import qualified Component       as Component
 import qualified Component.Modal as Modal
+import qualified Component.Modal as Modal
 import qualified Util.Ajax       as Ajax
 import qualified Util.Either     as EitherUtil
 import qualified Util.WaitFor    as WaitFor
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 6ed3b0e..9db4c7c 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -111,16 +111,14 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
             R.dynText . R.ffor exceedingPayer $ \ep ->
               Format.price currency $ _exceedingPayer_amount ep
 
-    addPaymentClic <- _buttonOut_clic <$> (Component.button $ ButtonIn
-      { _buttonIn_class = R.constDyn "addPayment"
-      , _buttonIn_content = R.text $ Msg.get Msg.Payment_Add
-      , _buttonIn_waiting = R.never
-      , _buttonIn_tabIndex = Nothing
-      , _buttonIn_submit = False
-      })
+    addPayment <- _buttonOut_clic <$>
+      (Component.button $
+        (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add))
+          { _buttonIn_class = R.constDyn "addPayment"
+          })
 
     Modal.view $ Modal.Input
-      { Modal._input_show    = addPaymentClic
+      { Modal._input_show    = addPayment
       , Modal._input_content = Add.view $ Add.Input
           { Add._input_categories = categories
           , Add._input_paymentCategories = paymentCategories
-- 
cgit v1.2.3


From 602c52acfcfa494b07fec05c20b317b60ea8a6f3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 21:31:57 +0200
Subject: Load init data per page with AJAX

---
 client/src/Model/Loadable.hs       |  51 ++++++++++++
 client/src/Util/Ajax.hs            |  21 +++--
 client/src/View/App.hs             |  16 ++--
 client/src/View/Header.hs          |   2 +-
 client/src/View/Income/Form.hs     |   4 +-
 client/src/View/Income/Header.hs   |  11 ++-
 client/src/View/Income/Income.hs   |  73 +++++++++++-----
 client/src/View/Income/Init.hs     |  11 +++
 client/src/View/Income/Table.hs    |  17 ++--
 client/src/View/Payment/Form.hs    |   4 +-
 client/src/View/Payment/Header.hs  |   6 +-
 client/src/View/Payment/Init.hs    |  13 +++
 client/src/View/Payment/Payment.hs | 165 +++++++++++++++++++++++--------------
 client/src/View/Payment/Table.hs   |  21 +++--
 client/src/View/SignIn.hs          |   2 +-
 15 files changed, 298 insertions(+), 119 deletions(-)
 create mode 100644 client/src/Model/Loadable.hs
 create mode 100644 client/src/View/Income/Init.hs
 create mode 100644 client/src/View/Payment/Init.hs

(limited to 'client/src')

diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs
new file mode 100644
index 0000000..3076b46
--- /dev/null
+++ b/client/src/Model/Loadable.hs
@@ -0,0 +1,51 @@
+module Model.Loadable
+  ( Loadable (..)
+  , fromEvent
+  , view
+  ) where
+
+import           Reflex.Dom   (MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Data.Functor (Functor)
+import           Data.Text    (Text)
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+data Loadable t
+  = Loading
+  | Error Text
+  | Loaded t
+
+instance Functor Loadable where
+  fmap f Loading    = Loading
+  fmap f (Error e)  = Error e
+  fmap f (Loaded x) = Loaded (f x)
+
+instance Applicative Loadable where
+  pure x = Loaded x
+
+  Loading <*> _ = Loading
+  (Error e) <*> _ = Error e
+  (Loaded f) <*> Loading = Loading
+  (Loaded f) <*> (Error e) = Error e
+  (Loaded f) <*> (Loaded x) = Loaded (f x)
+
+instance Monad Loadable where
+  Loading >>= f = Loading
+  (Error e) >>= f = Error e
+  (Loaded x) >>= f = f x
+
+fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a))
+fromEvent =
+  R.foldDyn
+    (\res _ -> case res of
+      Left err -> Error err
+      Right t  -> Loaded t
+    )
+    Loading
+
+view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m ()
+view _ (Loading)  = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
+view _ (Error e)  = R.text e
+view f (Loaded x) = f x
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index a4f6a74..9cd5105 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,6 +1,7 @@
 module Util.Ajax
-  ( postJson
-  , putJson
+  ( get
+  , post
+  , put
   , delete
   ) where
 
@@ -20,21 +21,29 @@ import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
                                        XhrResponseHeaders (..))
 import qualified Reflex.Dom           as R
 
-postJson
+get
+  :: forall t m a. (MonadWidget t m, FromJSON a)
+  => Event t Text
+  -> m (Event t (Either Text a))
+get url =
+  fmap getJsonResult <$>
+    R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
+
+post
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-postJson url input =
+post url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "POST" url <$> input)
 
-putJson
+put
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-putJson url input =
+put url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 3292336..b468e56 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -7,7 +7,8 @@ import           Prelude              hiding (error, init)
 import           Reflex.Dom           (Dynamic, MonadWidget)
 import qualified Reflex.Dom           as R
 
-import           Common.Model         (Init, InitResult (..))
+import           Common.Model         (Currency, Init (..), InitResult (..),
+                                       UserId)
 import qualified Common.Msg           as Msg
 
 import           Model.Route          (Route (..))
@@ -60,14 +61,19 @@ widget initResult =
 signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
-    RootRoute ->
+    RootRoute -> do
+      paymentInit <- Payment.init
       Payment.view $ PaymentIn
-        { _paymentIn_init = init
+        { _paymentIn_currentUser = _init_currentUser init
+        , _paymentIn_currency = _init_currency init
+        , _paymentIn_init = paymentInit
         }
 
-    IncomeRoute ->
+    IncomeRoute -> do
+      incomeInit <- Income.init
       Income.view $ IncomeIn
-        { _incomeIn_init = init
+        { _incomeIn_currency = _init_currency init
+        , _incomeIn_init = incomeInit
         }
 
     NotFoundRoute ->
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 9a4de89..bd69e47 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -73,7 +73,7 @@ links route = do
 
 nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
 nameSignOut initResult = case initResult of
-  (InitSuccess init) -> do
+  InitSuccess init -> do
     rec
       attr <- R.holdDyn
         (M.singleton "class" "nameSignOut")
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index b8a9094..2bfc23f 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -109,5 +109,5 @@ view formIn = do
   where
     ajax =
       case _formIn_httpMethod formIn of
-        Post -> Ajax.postJson
-        Put  -> Ajax.putJson
+        Post -> Ajax.post
+        Put  -> Ajax.put
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index e384161..4e08955 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -11,19 +11,22 @@ import qualified Data.Time.Clock        as Clock
 import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Income (..), Init (..), User (..))
+import           Common.Model           (Currency, Income (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
+
 import           Component              (ButtonOut (..))
 import qualified Component
 import qualified Component.Modal        as Modal
 import qualified Util.Date              as DateUtil
 import qualified View.Income.Add        as Add
+import           View.Income.Init       (Init (..))
 
 data HeaderIn t = HeaderIn
-  { _headerIn_init    :: Init
-  , _headerIn_incomes :: Dynamic t [Income]
+  { _headerIn_init     :: Init
+  , _headerIn_currency :: Currency
+  , _headerIn_incomes  :: Dynamic t [Income]
   }
 
 data HeaderOut t = HeaderOut
@@ -55,7 +58,7 @@ view headerIn =
                   T.intercalate " "
                     [ _user_name user
                     , "−"
-                    , Format.price (_init_currency init) $
+                    , Format.price (_headerIn_currency headerIn) $
                       CM.cumulativeIncomesSince currentTime since userIncomes
                     ]
 
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 167aedf..91682a0 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -1,40 +1,73 @@
 module View.Income.Income
-  ( view
+  ( init
+  , view
   , IncomeIn(..)
   ) where
 
+import           Prelude            hiding (init)
 import           Reflex.Dom         (Dynamic, MonadWidget)
 import qualified Reflex.Dom         as R
 
-import           Common.Model       (Init (..))
+import           Common.Model       (Currency)
+
+import           Model.Loadable     (Loadable (..))
+import qualified Model.Loadable     as Loadable
+import qualified Util.Ajax          as AjaxUtil
 import           View.Income.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Income.Header as Header
+import           View.Income.Init   (Init (..))
 import           View.Income.Table  (IncomeTableIn (..))
 import qualified View.Income.Table  as Table
 
-data IncomeIn = IncomeIn
-  { _incomeIn_init :: Init
+data IncomeIn t = IncomeIn
+  { _incomeIn_currency :: Currency
+  , _incomeIn_init     :: Dynamic t (Loadable Init)
   }
 
-view :: forall t m. MonadWidget t m => IncomeIn -> m ()
-view incomeIn =
-  R.elClass "main" "income" $ do
+init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
+init = do
+  postBuild <- R.getPostBuild
+
+  usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild)
+  users <- Loadable.fromEvent usersEvent
+
+  incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild)
+  incomes <- Loadable.fromEvent incomesEvent
+
+  paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild)
+  payments <- Loadable.fromEvent paymentsEvent
+
+  return $ do
+    us <- users
+    is <- incomes
+    ps <- payments
+    return $ Init <$> us <*> is <*> ps
+
+view :: forall t m. MonadWidget t m => IncomeIn t -> m ()
+view incomeIn = do
+  R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init ->
+
+    R.elClass "main" "income" $ do
+
+      rec
 
-    rec
+        incomes <- R.foldDyn
+          (:)
+          (_init_incomes init)
+          (_headerOut_addIncome header)
 
-      incomes <- R.foldDyn
-        (:)
-        (_init_incomes . _incomeIn_init $ incomeIn)
-        (_headerOut_addIncome header)
+        header <- Header.view $ HeaderIn
+          { _headerIn_init = init
+          , _headerIn_currency = _incomeIn_currency incomeIn
+          , _headerIn_incomes = incomes
+          }
 
-      header <- Header.view $ HeaderIn
-        { _headerIn_init = _incomeIn_init incomeIn
-        , _headerIn_incomes = incomes
+      Table.view $ IncomeTableIn
+        { _tableIn_init = init
+        , _tableIn_currency = _incomeIn_currency incomeIn
+        , _tableIn_incomes = incomes
         }
 
-    Table.view $ IncomeTableIn
-      { _tableIn_init = _incomeIn_init incomeIn
-      , _tableIn_incomes = incomes
-      }
+      return ()
 
-    return ()
+  return ()
diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs
new file mode 100644
index 0000000..4f3ef99
--- /dev/null
+++ b/client/src/View/Income/Init.hs
@@ -0,0 +1,11 @@
+module View.Income.Init
+  ( Init(..)
+  ) where
+
+import           Common.Model (Income, Payment, User)
+
+data Init = Init
+  { _init_users    :: [User]
+  , _init_incomes  :: [Income]
+  , _init_payments :: [Payment]
+  } deriving (Show)
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 5363ca5..d42848b 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -9,16 +9,19 @@ import           Data.Text          (Text)
 import           Reflex.Dom         (Dynamic, MonadWidget)
 import qualified Reflex.Dom         as R
 
-import           Common.Model       (Income (..), Init (..), User (..))
+import           Common.Model       (Currency, Income (..), User (..))
 import qualified Common.Model       as CM
 import qualified Common.Msg         as Msg
 import qualified Common.View.Format as Format
+
 import           Component          (TableIn (..))
 import qualified Component
+import           View.Income.Init   (Init (..))
 
 data IncomeTableIn t = IncomeTableIn
-  { _tableIn_init    :: Init
-  , _tableIn_incomes :: Dynamic t [Income]
+  { _tableIn_init     :: Init
+  , _tableIn_currency :: Currency
+  , _tableIn_incomes  :: Dynamic t [Income]
   }
 
 view :: forall t m. MonadWidget t m => IncomeTableIn t -> m ()
@@ -27,7 +30,7 @@ view tableIn = do
     Component.table $ TableIn
       { _tableIn_headerLabel = headerLabel
       , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date
-      , _tableIn_cell = cell (_tableIn_init tableIn)
+      , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn)
       , _tableIn_perPage = 7
       , _tableIn_resetPage = R.never
       }
@@ -45,8 +48,8 @@ headerLabel UserHeader   = Msg.get Msg.Income_Name
 headerLabel DateHeader   = Msg.get Msg.Income_Date
 headerLabel AmountHeader = Msg.get Msg.Income_Amount
 
-cell :: Init -> Header -> Income -> Text
-cell init header income =
+cell :: Init -> Currency -> Header -> Income -> Text
+cell init currency header income =
   case header of
     UserHeader ->
       Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
@@ -55,4 +58,4 @@ cell init header income =
       Format.longDay . _income_date $ income
 
     AmountHeader ->
-      Format.price (_init_currency init) . _income_amount $ income
+      Format.price currency . _income_amount $ income
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 7819836..c817831 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -165,8 +165,8 @@ view input = do
 
     ajax =
       case _input_httpMethod input of
-        Post -> Ajax.postJson
-        Put  -> Ajax.putJson
+        Post -> Ajax.post
+        Put  -> Ajax.put
 
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
 findCategory paymentName =
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 9db4c7c..9ad90a9 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -20,7 +20,7 @@ import qualified Reflex.Dom             as R
 
 import           Common.Model           (Category, Currency,
                                          ExceedingPayer (..), Frequency (..),
-                                         Income (..), Init (..), Payment (..),
+                                         Income (..), Payment (..),
                                          PaymentCategory, SavedPayment (..),
                                          User (..))
 import qualified Common.Model           as CM
@@ -34,9 +34,11 @@ import qualified Component              as Component
 import qualified Component.Modal        as Modal
 import qualified Util.List              as L
 import qualified View.Payment.Add       as Add
+import           View.Payment.Init      (Init (..))
 
 data HeaderIn t = HeaderIn
   { _headerIn_init              :: Init
+  , _headerIn_currency          :: Currency
   , _headerIn_payments          :: Dynamic t [Payment]
   , _headerIn_searchPayments    :: Dynamic t [Payment]
   , _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
@@ -78,7 +80,7 @@ widget headerIn =
     payments = _headerIn_payments headerIn
     users = _init_users init
     categories = _init_categories init
-    currency = _init_currency init
+    currency = _headerIn_currency headerIn
     paymentCategories = _headerIn_paymentCategories headerIn
 
 payerAndAdd
diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs
new file mode 100644
index 0000000..d9f85c8
--- /dev/null
+++ b/client/src/View/Payment/Init.hs
@@ -0,0 +1,13 @@
+module View.Payment.Init
+  ( Init(..)
+  ) where
+
+import           Common.Model (Category, Income, Payment, PaymentCategory, User)
+
+data Init = Init
+  { _init_users             :: [User]
+  , _init_payments          :: [Payment]
+  , _init_incomes           :: [Income]
+  , _init_categories        :: [Category]
+  , _init_paymentCategories :: [PaymentCategory]
+  } deriving (Show)
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index cfdb441..ec350e2 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -1,5 +1,6 @@
 module View.Payment.Payment
-  ( view
+  ( init
+  , view
   , PaymentIn(..)
   ) where
 
@@ -10,78 +11,118 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Frequency, Init (..), Payment (..),
-                                      PaymentCategory (..), PaymentId,
-                                      SavedPayment (..))
+import           Common.Model        (Currency, Frequency, Income (..),
+                                      Payment (..), PaymentCategory (..),
+                                      PaymentId, SavedPayment (..), User,
+                                      UserId)
 import qualified Common.Util.Text    as T
+
+import           Model.Loadable      (Loadable (..))
+import qualified Model.Loadable      as Loadable
+import qualified Util.Ajax           as AjaxUtil
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
+import           View.Payment.Init   (Init (..))
 import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
 import qualified View.Payment.Pages  as Pages
 import           View.Payment.Table  (TableIn (..), TableOut (..))
 import qualified View.Payment.Table  as Table
 
-data PaymentIn = PaymentIn
-  { _paymentIn_init :: Init
+init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
+init = do
+  postBuild <- R.getPostBuild
+
+  incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild)
+  incomes <- Loadable.fromEvent incomesEvent
+
+  usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild)
+  users <- Loadable.fromEvent usersEvent
+
+  paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild)
+  payments <- Loadable.fromEvent paymentsEvent
+
+  paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild)
+  paymentCategories <- Loadable.fromEvent paymentCategoriesEvent
+
+  categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild)
+  categories <- Loadable.fromEvent categoriesEvent
+
+  return $ do
+    us <- users
+    ps <- payments
+    is <- incomes
+    cs <- categories
+    pcs <- paymentCategories
+    return $ Init <$> us <*> ps <*> is <*> cs <*> pcs
+
+data PaymentIn t = PaymentIn
+  { _paymentIn_currentUser :: UserId
+  , _paymentIn_currency    :: Currency
+  , _paymentIn_init        :: Dynamic t (Loadable Init)
   }
 
-view :: forall t m. MonadWidget t m => PaymentIn -> m ()
+view :: forall t m. MonadWidget t m => PaymentIn t -> m ()
 view paymentIn = do
-  R.elClass "main" "payment" $ do
-    rec
-      let init = _paymentIn_init paymentIn
-
-          paymentsPerPage = 7
-
-          addPayment = R.leftmost
-            [ _headerOut_addPayment header
-            , _tableOut_addPayment table
-            ]
-
-      payments <- reducePayments
-        (_init_payments init)
-        (_savedPayment_payment <$> addPayment)
-        (_savedPayment_payment <$> _tableOut_editPayment table)
-        (_tableOut_deletePayment table)
-
-      paymentCategories <- reducePaymentCategories
-        (_init_paymentCategories init)
-        payments
-        (_savedPayment_paymentCategory <$> addPayment)
-        (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
-        (_tableOut_deletePayment table)
-
-      (searchNameEvent, searchName) <-
-        debounceSearchName (_headerOut_searchName header)
-
-      let searchPayments =
-            getSearchPayments searchName (_headerOut_searchFrequency header) payments
-
-      header <- Header.widget $ HeaderIn
-        { _headerIn_init = init
-        , _headerIn_payments = payments
-        , _headerIn_searchPayments = searchPayments
-        , _headerIn_paymentCategories = paymentCategories
-        }
-
-      table <- Table.widget $ TableIn
-        { _tableIn_init = init
-        , _tableIn_currentPage = _pagesOut_currentPage pages
-        , _tableIn_payments = searchPayments
-        , _tableIn_perPage = paymentsPerPage
-        , _tableIn_paymentCategories = paymentCategories
-        }
-
-      pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> searchPayments
-        , _pagesIn_perPage = paymentsPerPage
-        , _pagesIn_reset = R.leftmost $
-            [ () <$ searchNameEvent
-            , () <$ _headerOut_addPayment header
-            ]
-        }
-
-    pure ()
+  R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init ->
+
+    R.elClass "main" "payment" $ do
+      rec
+        let addPayment = R.leftmost
+              [ _headerOut_addPayment header
+              , _tableOut_addPayment table
+              ]
+
+            paymentsPerPage = 7
+
+        payments <- reducePayments
+          (_init_payments init)
+          (_savedPayment_payment <$> addPayment)
+          (_savedPayment_payment <$> _tableOut_editPayment table)
+          (_tableOut_deletePayment table)
+
+        paymentCategories <- reducePaymentCategories
+          (_init_paymentCategories init)
+          payments
+          (_savedPayment_paymentCategory <$> addPayment)
+          (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
+          (_tableOut_deletePayment table)
+
+        (searchNameEvent, searchName) <-
+          debounceSearchName (_headerOut_searchName header)
+
+        let searchPayments =
+              getSearchPayments searchName (_headerOut_searchFrequency header) payments
+
+        header <- Header.widget $ HeaderIn
+          { _headerIn_init = init
+          , _headerIn_currency = _paymentIn_currency paymentIn
+          , _headerIn_payments = payments
+          , _headerIn_searchPayments = searchPayments
+          , _headerIn_paymentCategories = paymentCategories
+          }
+
+        table <- Table.widget $ TableIn
+          { _tableIn_init = init
+          , _tableIn_currency = _paymentIn_currency paymentIn
+          , _tableIn_currentUser = _paymentIn_currentUser paymentIn
+          , _tableIn_currentPage = _pagesOut_currentPage pages
+          , _tableIn_payments = searchPayments
+          , _tableIn_perPage = paymentsPerPage
+          , _tableIn_paymentCategories = paymentCategories
+          }
+
+        pages <- Pages.widget $ PagesIn
+          { _pagesIn_total = length <$> searchPayments
+          , _pagesIn_perPage = paymentsPerPage
+          , _pagesIn_reset = R.leftmost $
+              [ () <$ searchNameEvent
+              , () <$ _headerOut_addPayment header
+              ]
+          }
+
+      pure ()
+
+  return ()
 
 debounceSearchName
   :: forall t m. MonadWidget t m
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index bf6b604..5ffa037 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,10 +13,10 @@ import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Category (..), Frequency (Punctual),
-                                      Init (..), Payment (..),
+import           Common.Model        (Category (..), Currency,
+                                      Frequency (Punctual), Payment (..),
                                       PaymentCategory (..), SavedPayment,
-                                      User (..))
+                                      User (..), UserId)
 import qualified Common.Model        as CM
 import qualified Common.Msg          as Msg
 import qualified Common.View.Format  as Format
@@ -26,12 +26,15 @@ import qualified Component.Modal     as Modal
 import qualified View.Payment.Clone  as Clone
 import qualified View.Payment.Delete as Delete
 import qualified View.Payment.Edit   as Edit
+import           View.Payment.Init   (Init (..))
 
 import qualified Icon
 import qualified Util.Reflex         as ReflexUtil
 
 data TableIn t = TableIn
   { _tableIn_init              :: Init
+  , _tableIn_currency          :: Currency
+  , _tableIn_currentUser       :: UserId
   , _tableIn_currentPage       :: Dynamic t Int
   , _tableIn_payments          :: Dynamic t [Payment]
   , _tableIn_perPage           :: Int
@@ -61,7 +64,7 @@ widget tableIn = do
         R.divClass "cell" $ R.blank
 
       result <-
-        (R.simpleList paymentRange (paymentRow init paymentCategories))
+        (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories))
 
       return $
         ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
@@ -80,6 +83,8 @@ widget tableIn = do
 
   where
     init = _tableIn_init tableIn
+    currency = _tableIn_currency tableIn
+    currentUser = _tableIn_currentUser tableIn
     currentPage = _tableIn_currentPage tableIn
     payments = _tableIn_payments tableIn
     paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
@@ -96,17 +101,19 @@ getPaymentRange perPage payments currentPage =
 paymentRow
   :: forall t m. MonadWidget t m
   => Init
+  -> Currency
+  -> UserId
   -> Dynamic t [PaymentCategory]
   -> Dynamic t Payment
   -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
-paymentRow init paymentCategories payment =
+paymentRow init currency currentUser paymentCategories payment =
   R.divClass "row" $ do
 
     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
+      R.dynText $ fmap (Format.price currency . _payment_cost) payment
 
     let user = R.ffor payment (\p ->
           CM.findUser (_payment_user p) (_init_users init))
@@ -162,7 +169,7 @@ paymentRow init paymentCategories payment =
     let isFromCurrentUser =
           R.ffor
             payment
-            (\p -> _payment_user p == _init_currentUser init)
+            (\p -> _payment_user p == currentUser)
 
     editPayment <-
       R.divClass "cell button" $
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 8c248bd..4fe495b 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -50,7 +50,7 @@ view signInMessage =
         let form = SignInForm <$> _inputOut_raw input
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.postJson "/api/askSignIn")
+          (Ajax.post "/api/askSignIn")
           (ValidationUtil.fireMaybe
             ((\f -> f <$ SignInValidation.signIn f) <$> form)
             validate)
-- 
cgit v1.2.3


From 33e78f2ebbf5bf7b40e7aa732cc7c019f6df3f12 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Oct 2019 22:08:31 +0200
Subject: Simplify page initialization

---
 client/src/Component/Button.hs     |  2 +-
 client/src/Component/Input.hs      |  2 +-
 client/src/Component/Pages.hs      |  2 +-
 client/src/Icon.hs                 | 71 --------------------------------------
 client/src/Loadable.hs             | 51 +++++++++++++++++++++++++++
 client/src/Model/Loadable.hs       | 51 ---------------------------
 client/src/Util/Ajax.hs            | 11 +++++-
 client/src/View/Header.hs          |  2 +-
 client/src/View/Icon.hs            | 71 ++++++++++++++++++++++++++++++++++++++
 client/src/View/Income/Income.hs   | 19 ++++------
 client/src/View/Payment/Pages.hs   |  2 +-
 client/src/View/Payment/Payment.hs | 27 +++++----------
 client/src/View/Payment/Table.hs   |  2 +-
 13 files changed, 152 insertions(+), 161 deletions(-)
 delete mode 100644 client/src/Icon.hs
 create mode 100644 client/src/Loadable.hs
 delete mode 100644 client/src/Model/Loadable.hs
 create mode 100644 client/src/View/Icon.hs

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 46c0afa..b1175d7 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -12,7 +12,7 @@ import qualified Data.Text  as T
 import           Reflex.Dom (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom as R
 
-import qualified Icon
+import qualified View.Icon  as Icon
 
 data ButtonIn t m = ButtonIn
   { _buttonIn_class    :: Dynamic t Text
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 0c84754..9ab4d58 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -19,7 +19,7 @@ import qualified Reflex.Dom             as R
 import qualified Common.Util.Validation as ValidationUtil
 import           Component.Button       (ButtonIn (..), ButtonOut (..))
 import qualified Component.Button       as Button
-import qualified Icon
+import qualified View.Icon              as Icon
 
 data InputIn a = InputIn
   { _inputIn_hasResetButton :: Bool
diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
index 5611cb7..7843ef6 100644
--- a/client/src/Component/Pages.hs
+++ b/client/src/Component/Pages.hs
@@ -11,8 +11,8 @@ 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
+import qualified View.Icon        as Icon
 
 data PagesIn t = PagesIn
   { _pagesIn_total   :: Dynamic t Int
diff --git a/client/src/Icon.hs b/client/src/Icon.hs
deleted file mode 100644
index 1a45933..0000000
--- a/client/src/Icon.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module Icon
-  ( clone
-  , cross
-  , delete
-  , edit
-  , loading
-  , doubleLeft
-  , doubleLeftBar
-  , doubleRight
-  , doubleRightBar
-  , signOut
-  ) where
-
-import           Data.Map   (Map)
-import qualified Data.Map   as M
-import           Data.Text  (Text)
-import           Reflex.Dom (MonadWidget)
-import qualified Reflex.Dom as R
-
-clone :: forall t m. MonadWidget t m => m ()
-clone =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
-    svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
-
-cross :: forall t m. MonadWidget t m => m ()
-cross =
-  svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank
-
-delete :: forall t m. MonadWidget t m => m ()
-delete =
-  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank
-
-doubleLeft :: forall t m. MonadWidget t m => m ()
-doubleLeft =
-  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank
-
-doubleLeftBar :: forall t m. MonadWidget t m => m ()
-doubleLeftBar =
-  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank
-
-doubleRight :: forall t m. MonadWidget t m => m ()
-doubleRight =
-  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
-
-doubleRightBar :: forall t m. MonadWidget t m => m ()
-doubleRightBar =
-  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
-
-edit :: forall t m. MonadWidget t m => m ()
-edit =
-  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank
-
-loading :: forall t m. MonadWidget t m => m ()
-loading =
-  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $
-    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
-
-signOut :: forall t m. MonadWidget t m => m ()
-signOut =
-  svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $
-    svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank
-
-svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
-svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
new file mode 100644
index 0000000..8714a4d
--- /dev/null
+++ b/client/src/Loadable.hs
@@ -0,0 +1,51 @@
+module Loadable
+  ( Loadable (..)
+  , fromEvent
+  , view
+  ) where
+
+import           Reflex.Dom   (MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Data.Functor (Functor)
+import           Data.Text    (Text)
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+data Loadable t
+  = Loading
+  | Error Text
+  | Loaded t
+
+instance Functor Loadable where
+  fmap f Loading    = Loading
+  fmap f (Error e)  = Error e
+  fmap f (Loaded x) = Loaded (f x)
+
+instance Applicative Loadable where
+  pure x = Loaded x
+
+  Loading <*> _ = Loading
+  (Error e) <*> _ = Error e
+  (Loaded f) <*> Loading = Loading
+  (Loaded f) <*> (Error e) = Error e
+  (Loaded f) <*> (Loaded x) = Loaded (f x)
+
+instance Monad Loadable where
+  Loading >>= f = Loading
+  (Error e) >>= f = Error e
+  (Loaded x) >>= f = f x
+
+fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a))
+fromEvent =
+  R.foldDyn
+    (\res _ -> case res of
+      Left err -> Error err
+      Right t  -> Loaded t
+    )
+    Loading
+
+view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m ()
+view _ (Loading)  = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
+view _ (Error e)  = R.text e
+view f (Loaded x) = f x
diff --git a/client/src/Model/Loadable.hs b/client/src/Model/Loadable.hs
deleted file mode 100644
index 3076b46..0000000
--- a/client/src/Model/Loadable.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-module Model.Loadable
-  ( Loadable (..)
-  , fromEvent
-  , view
-  ) where
-
-import           Reflex.Dom   (MonadWidget)
-import qualified Reflex.Dom   as R
-
-import           Data.Functor (Functor)
-import           Data.Text    (Text)
-import           Reflex.Dom   (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom   as R
-
-data Loadable t
-  = Loading
-  | Error Text
-  | Loaded t
-
-instance Functor Loadable where
-  fmap f Loading    = Loading
-  fmap f (Error e)  = Error e
-  fmap f (Loaded x) = Loaded (f x)
-
-instance Applicative Loadable where
-  pure x = Loaded x
-
-  Loading <*> _ = Loading
-  (Error e) <*> _ = Error e
-  (Loaded f) <*> Loading = Loading
-  (Loaded f) <*> (Error e) = Error e
-  (Loaded f) <*> (Loaded x) = Loaded (f x)
-
-instance Monad Loadable where
-  Loading >>= f = Loading
-  (Error e) >>= f = Error e
-  (Loaded x) >>= f = f x
-
-fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a))
-fromEvent =
-  R.foldDyn
-    (\res _ -> case res of
-      Left err -> Error err
-      Right t  -> Loaded t
-    )
-    Loading
-
-view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m ()
-view _ (Loading)  = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
-view _ (Error e)  = R.text e
-view f (Loaded x) = f x
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 9cd5105..47f4f3c 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -1,5 +1,6 @@
 module Util.Ajax
-  ( get
+  ( getNow
+  , get
   , post
   , put
   , delete
@@ -21,6 +22,14 @@ import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
                                        XhrResponseHeaders (..))
 import qualified Reflex.Dom           as R
 
+import           Loadable             (Loadable)
+import qualified Loadable
+
+getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
+getNow url = do
+  postBuild <- R.getPostBuild
+  get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent
+
 get
   :: forall t m a. (MonadWidget t m, FromJSON a)
   => Event t Text
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index bd69e47..68329eb 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -18,10 +18,10 @@ import qualified Common.Model as CM
 import qualified Common.Msg   as Msg
 import           Component    (ButtonIn (..))
 import qualified Component    as Component
-import qualified Icon
 import           Model.Route  (Route (..))
 import qualified Util.Css     as CssUtil
 import qualified Util.Reflex  as ReflexUtil
+import qualified View.Icon    as Icon
 
 data HeaderIn t = HeaderIn
   { _headerIn_initResult    :: InitResult
diff --git a/client/src/View/Icon.hs b/client/src/View/Icon.hs
new file mode 100644
index 0000000..cc2ef3f
--- /dev/null
+++ b/client/src/View/Icon.hs
@@ -0,0 +1,71 @@
+module View.Icon
+  ( clone
+  , cross
+  , delete
+  , edit
+  , loading
+  , doubleLeft
+  , doubleLeftBar
+  , doubleRight
+  , doubleRightBar
+  , signOut
+  ) where
+
+import           Data.Map   (Map)
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import           Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+clone :: forall t m. MonadWidget t m => m ()
+clone =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+    svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
+
+cross :: forall t m. MonadWidget t m => m ()
+cross =
+  svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank
+
+delete :: forall t m. MonadWidget t m => m ()
+delete =
+  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M704 1376v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm256 0v-704q0-14-9-23t-23-9h-64q-14 0-23 9t-9 23v704q0 14 9 23t23 9h64q14 0 23-9t9-23zm-544-992h448l-48-117q-7-9-17-11h-317q-10 2-17 11zm928 32v64q0 14-9 23t-23 9h-96v948q0 83-47 143.5t-113 60.5h-832q-66 0-113-58.5t-47-141.5v-952h-96q-14 0-23-9t-9-23v-64q0-14 9-23t23-9h309l70-167q15-37 54-63t79-26h320q40 0 79 26t54 63l70 167h309q14 0 23 9t9 23z")]) $ R.blank
+
+doubleLeft :: forall t m. MonadWidget t m => m ()
+doubleLeft =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1683 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-8-9-13-19v710q0 26-13 32t-32-13l-710-710q-19-19-19-45t19-45l710-710q19-19 32-13t13 32v710q5-11 13-19z")]) $ R.blank
+
+doubleLeftBar :: forall t m. MonadWidget t m => m ()
+doubleLeftBar =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1747 141q19-19 32-13t13 32v1472q0 26-13 32t-32-13l-710-710q-9-9-13-19v710q0 26-13 32t-32-13l-710-710q-9-9-13-19v678q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-1408q0-26 19-45t45-19h128q26 0 45 19t19 45v678q4-11 13-19l710-710q19-19 32-13t13 32v710q4-11 13-19z")]) $ R.blank
+
+doubleRight :: forall t m. MonadWidget t m => m ()
+doubleRight =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M109 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q19 19 19 45t-19 45l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
+
+doubleRightBar :: forall t m. MonadWidget t m => m ()
+doubleRightBar =
+  svgAttr "svg" (M.fromList [ ("width", "13"), ("height", "13"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M45 1651q-19 19-32 13t-13-32v-1472q0-26 13-32t32 13l710 710q8 8 13 19v-710q0-26 13-32t32 13l710 710q8 8 13 19v-678q0-26 19-45t45-19h128q26 0 45 19t19 45v1408q0 26-19 45t-45 19h-128q-26 0-45-19t-19-45v-678q-5 10-13 19l-710 710q-19 19-32 13t-13-32v-710q-5 10-13 19z")]) $ R.blank
+
+edit :: forall t m. MonadWidget t m => m ()
+edit =
+  svgAttr "svg" (M.fromList [ ("width", "18"), ("height", "18"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M491 1536l91-91-235-235-91 91v107h128v128h107zm523-928q0-22-22-22-10 0-17 7l-542 542q-7 7-7 17 0 22 22 22 10 0 17-7l542-542q7-7 7-17zm-54-192l416 416-832 832h-416v-416zm683 96q0 53-37 90l-166 166-416-416 166-165q36-38 90-38 53 0 91 38l235 234q37 39 37 91z")]) $ R.blank
+
+loading :: forall t m. MonadWidget t m => m ()
+loading =
+  svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader"), ("fill", "currentColor") ]) $
+    svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
+
+signOut :: forall t m. MonadWidget t m => m ()
+signOut =
+  svgAttr "svg" (M.fromList [ ("width", "30"), ("height", "30"), ("viewBox", "0 0 1792 1792") ]) $
+    svgAttr "path" (M.fromList [("d", "M1664 896q0 156-61 298t-164 245-245 164-298 61-298-61-245-164-164-245-61-298q0-182 80.5-343t226.5-270q43-32 95.5-25t83.5 50q32 42 24.5 94.5t-49.5 84.5q-98 74-151.5 181t-53.5 228q0 104 40.5 198.5t109.5 163.5 163.5 109.5 198.5 40.5 198.5-40.5 163.5-109.5 109.5-163.5 40.5-198.5q0-121-53.5-228t-151.5-181q-42-32-49.5-84.5t24.5-94.5q31-43 84-50t95 25q146 109 226.5 270t80.5 343zm-640-768v640q0 52-38 90t-90 38-90-38-38-90v-640q0-52 38-90t90-38 90 38 38 90z")]) $ R.blank
+
+svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
+svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 91682a0..18ebe7c 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -4,14 +4,15 @@ module View.Income.Income
   , IncomeIn(..)
   ) where
 
+import           Data.Aeson         (FromJSON)
 import           Prelude            hiding (init)
 import           Reflex.Dom         (Dynamic, MonadWidget)
 import qualified Reflex.Dom         as R
 
 import           Common.Model       (Currency)
 
-import           Model.Loadable     (Loadable (..))
-import qualified Model.Loadable     as Loadable
+import           Loadable           (Loadable (..))
+import qualified Loadable
 import qualified Util.Ajax          as AjaxUtil
 import           View.Income.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Income.Header as Header
@@ -26,17 +27,9 @@ data IncomeIn t = IncomeIn
 
 init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
 init = do
-  postBuild <- R.getPostBuild
-
-  usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild)
-  users <- Loadable.fromEvent usersEvent
-
-  incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild)
-  incomes <- Loadable.fromEvent incomesEvent
-
-  paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild)
-  payments <- Loadable.fromEvent paymentsEvent
-
+  users <- AjaxUtil.getNow "api/users"
+  incomes <- AjaxUtil.getNow "api/incomes"
+  payments <- AjaxUtil.getNow "api/payments"
   return $ do
     us <- users
     is <- incomes
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 9247143..5681935 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -11,8 +11,8 @@ import qualified Reflex.Dom  as R
 import           Component   (ButtonIn (..), ButtonOut (..))
 import qualified Component   as Component
 
-import qualified Icon
 import qualified Util.Reflex as ReflexUtil
+import qualified View.Icon   as Icon
 
 data PagesIn t = PagesIn
   { _pagesIn_total   :: Dynamic t Int
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index ec350e2..5f0d03c 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -17,8 +17,8 @@ import           Common.Model        (Currency, Frequency, Income (..),
                                       UserId)
 import qualified Common.Util.Text    as T
 
-import           Model.Loadable      (Loadable (..))
-import qualified Model.Loadable      as Loadable
+import           Loadable            (Loadable (..))
+import qualified Loadable
 import qualified Util.Ajax           as AjaxUtil
 import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
@@ -30,23 +30,11 @@ import qualified View.Payment.Table  as Table
 
 init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
 init = do
-  postBuild <- R.getPostBuild
-
-  incomesEvent <- AjaxUtil.get (R.tag (R.constant "api/incomes") postBuild)
-  incomes <- Loadable.fromEvent incomesEvent
-
-  usersEvent <- AjaxUtil.get (R.tag (R.constant "api/users") postBuild)
-  users <- Loadable.fromEvent usersEvent
-
-  paymentsEvent <- AjaxUtil.get (R.tag (R.constant "api/payments") postBuild)
-  payments <- Loadable.fromEvent paymentsEvent
-
-  paymentCategoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/paymentCategories") postBuild)
-  paymentCategories <- Loadable.fromEvent paymentCategoriesEvent
-
-  categoriesEvent <- AjaxUtil.get (R.tag (R.constant "api/categories") postBuild)
-  categories <- Loadable.fromEvent categoriesEvent
-
+  users <- AjaxUtil.getNow "api/users"
+  payments <- AjaxUtil.getNow "api/payments"
+  incomes <- AjaxUtil.getNow "api/incomes"
+  categories <- AjaxUtil.getNow "api/categories"
+  paymentCategories <- AjaxUtil.getNow "api/paymentCategories"
   return $ do
     us <- users
     ps <- payments
@@ -55,6 +43,7 @@ init = do
     pcs <- paymentCategories
     return $ Init <$> us <*> ps <*> is <*> cs <*> pcs
 
+
 data PaymentIn t = PaymentIn
   { _paymentIn_currentUser :: UserId
   , _paymentIn_currency    :: Currency
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 5ffa037..3a0a4bf 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -28,8 +28,8 @@ import qualified View.Payment.Delete as Delete
 import qualified View.Payment.Edit   as Edit
 import           View.Payment.Init   (Init (..))
 
-import qualified Icon
 import qualified Util.Reflex         as ReflexUtil
+import qualified View.Icon           as Icon
 
 data TableIn t = TableIn
   { _tableIn_init              :: Init
-- 
cgit v1.2.3


From 80f09e8b3a5c856e60922a73c9161a8c5392e4d4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 22 Oct 2019 21:35:03 +0200
Subject: Create ModalForm component

---
 client/src/Component.hs           |  15 +--
 client/src/Component/ModalForm.hs |  70 +++++++++++++
 client/src/View/Income/Add.hs     |   3 +-
 client/src/View/Income/Form.hs    | 138 +++++++++++--------------
 client/src/View/Payment/Add.hs    |   3 +-
 client/src/View/Payment/Clone.hs  |   3 +-
 client/src/View/Payment/Edit.hs   |   3 +-
 client/src/View/Payment/Form.hs   | 205 +++++++++++++++++---------------------
 8 files changed, 233 insertions(+), 207 deletions(-)
 create mode 100644 client/src/Component/ModalForm.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
index b715a83..fa4e4ea 100644
--- a/client/src/Component.hs
+++ b/client/src/Component.hs
@@ -1,9 +1,10 @@
 module Component (module X) where
 
-import           Component.Button as X
-import           Component.Form   as X
-import           Component.Input  as X
-import           Component.Link   as X
-import           Component.Pages  as X
-import           Component.Select as X
-import           Component.Table  as X
+import           Component.Button    as X
+import           Component.Form      as X
+import           Component.Input     as X
+import           Component.Link      as X
+import           Component.ModalForm as X
+import           Component.Pages     as X
+import           Component.Select    as X
+import           Component.Table     as X
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
new file mode 100644
index 0000000..63cb1d2
--- /dev/null
+++ b/client/src/Component/ModalForm.hs
@@ -0,0 +1,70 @@
+module Component.ModalForm
+  ( modalForm
+  , ModalFormIn(..)
+  , ModalFormOut(..)
+  ) where
+
+import           Data.Aeson         (ToJSON)
+import           Data.Text          (Text)
+import qualified Data.Text          as T
+import           Data.Time.Calendar (Day)
+import           Data.Validation    (Validation)
+import qualified Data.Validation    as V
+import           Reflex.Dom         (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom         as R
+
+import qualified Common.Msg         as Msg
+import           Component.Button   (ButtonIn (..))
+import qualified Component.Button   as Button
+import qualified Util.Either        as EitherUtil
+import qualified Util.Validation    as ValidationUtil
+import qualified Util.WaitFor       as WaitFor
+
+data ModalFormIn m t a b e = ModalFormIn
+  { _modalFormIn_headerLabel :: Text
+  , _modalFormIn_form        :: m (Dynamic t (Validation e a))
+  , _modalFormIn_ajax        :: Event t a -> m (Event t (Either Text b))
+  }
+
+data ModalFormOut t a = ModalFormOut
+  { _modalFormOut_hide     :: Event t ()
+  , _modalFormOut_cancel   :: Event t ()
+  , _modalFormOut_confirm  :: Event t ()
+  , _modalFormOut_validate :: Event t a
+  }
+
+modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b)
+modalForm modalFormIn =
+  R.divClass "form" $ do
+    R.divClass "formHeader" $
+      R.text (_modalFormIn_headerLabel modalFormIn)
+
+    R.divClass "formContent" $ do
+      rec
+        form <- _modalFormIn_form modalFormIn
+
+        (validate, cancel, confirm) <- R.divClass "buttons" $ do
+          rec
+            cancel <- Button._buttonOut_clic <$> (Button.button $
+              (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
+                { _buttonIn_class = R.constDyn "undo" })
+
+            confirm <- Button._buttonOut_clic <$> (Button.button $
+              (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
+                { _buttonIn_class = R.constDyn "confirm"
+                , _buttonIn_waiting = waiting
+                , _buttonIn_submit = True
+                })
+
+            (validate, waiting) <- WaitFor.waitFor
+              (_modalFormIn_ajax modalFormIn)
+              (ValidationUtil.fireValidation form confirm)
+
+          return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
+
+      return ModalFormOut
+        { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ]
+        , _modalFormOut_cancel = cancel
+        , _modalFormOut_confirm = confirm
+        , _modalFormOut_validate = validate
+        }
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
index d83bb51..0b1bd04 100644
--- a/client/src/View/Income/Add.hs
+++ b/client/src/View/Income/Add.hs
@@ -11,6 +11,7 @@ import           Common.Model           (CreateIncomeForm (..), Income)
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as TimeUtil
 import qualified Component.Modal        as Modal
+import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
 import           View.Income.Form       (FormIn (..), FormOut (..))
 import qualified View.Income.Form       as Form
@@ -27,7 +28,7 @@ view cancel = do
       , _formIn_amount = ""
       , _formIn_date = currentDay
       , _formIn_mkPayload = CreateIncomeForm
-      , _formIn_httpMethod = Form.Post
+      , _formIn_ajax = Ajax.post
       }
 
   hide <- ReflexUtil.flatten (_formOut_hide <$> form)
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index 2bfc23f..824bb0a 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -1,113 +1,89 @@
 module View.Income.Form
   ( view
   , FormIn(..)
-  , HttpMethod(..)
   , FormOut(..)
   ) where
 
-import           Data.Aeson               (ToJSON)
+import           Data.Aeson               (FromJSON, ToJSON)
 import           Data.Text                (Text)
 import qualified Data.Text                as T
 import           Data.Time.Calendar       (Day)
 import qualified Data.Time.Calendar       as Calendar
+import           Data.Validation          (Validation)
 import qualified Data.Validation          as V
-import           Reflex.Dom               (Event, MonadWidget)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom               as R
 
 import           Common.Model             (Income)
 import qualified Common.Msg               as Msg
 import qualified Common.Validation.Income as IncomeValidation
-import           Component                (ButtonIn (..), InputIn (..),
-                                           InputOut (..))
+import           Component                (InputIn (..), InputOut (..),
+                                           ModalFormIn (..), ModalFormOut (..))
 import qualified Component                as Component
-import qualified Util.Ajax                as Ajax
-import qualified Util.Either              as EitherUtil
-import qualified Util.Validation          as ValidationUtil
-import qualified Util.WaitFor             as WaitFor
 
-data FormIn t i = FormIn
+data FormIn m t a = FormIn
   { _formIn_cancel      :: Event t ()
   , _formIn_headerLabel :: Text
   , _formIn_amount      :: Text
   , _formIn_date        :: Day
-  , _formIn_mkPayload   :: Text -> Text -> i
-  , _formIn_httpMethod  :: HttpMethod
+  , _formIn_mkPayload   :: Text -> Text -> a
+  , _formIn_ajax        :: Text -> Event t a -> m (Event t (Either Text Income))
   }
 
-data HttpMethod = Put | Post
-
 data FormOut t = FormOut
   { _formOut_hide      :: Event t ()
   , _formOut_addIncome :: Event t Income
   }
 
-view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t)
+view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t)
 view formIn = do
-  R.divClass "form" $ do
-    R.divClass "formHeader" $
-      R.text (_formIn_headerLabel formIn)
-
-    R.divClass "formContent" $ do
-      rec
-        let reset = R.leftmost
-              [ "" <$ cancel
-              , "" <$ addIncome
-              , "" <$ _formIn_cancel formIn
-              ]
-
-        amount <- _inputOut_raw <$> (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Income_Amount
-            , _inputIn_initialValue = _formIn_amount formIn
-            , _inputIn_validation = IncomeValidation.amount
-            })
-          (_formIn_amount formIn <$ reset)
-          confirm)
-
-        let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
-
-        date <- _inputOut_raw <$> (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Income_Date
-            , _inputIn_initialValue = initialDate
-            , _inputIn_inputType = "date"
-            , _inputIn_hasResetButton = False
-            , _inputIn_validation = IncomeValidation.date
-            })
-          (initialDate <$ reset)
-          confirm)
-
-        let income = do
-              a <- amount
-              d <- date
-              return . V.Success $ (_formIn_mkPayload formIn) a d
-
-        (addIncome, cancel, confirm) <- R.divClass "buttons" $ do
-          rec
-            cancel <- Component._buttonOut_clic <$> (Component.button $
-              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-                { _buttonIn_class = R.constDyn "undo" })
-
-            confirm <- Component._buttonOut_clic <$> (Component.button $
-              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
-                { _buttonIn_class = R.constDyn "confirm"
-                , _buttonIn_waiting = waiting
-                , _buttonIn_submit = True
-                })
-
-            (addIncome, waiting) <- WaitFor.waitFor
-              (ajax "/api/income")
-              (ValidationUtil.fireValidation income confirm)
-
-          return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm)
-
-      return FormOut
-        { _formOut_hide = R.leftmost [ cancel, () <$ addIncome ]
-        , _formOut_addIncome = addIncome
-        }
+  rec
+    let reset = R.leftmost
+          [ "" <$ _modalFormOut_cancel modalForm
+          , "" <$ _modalFormOut_validate modalForm
+          , "" <$ _formIn_cancel formIn
+          ]
+
+    modalForm <- Component.modalForm $ ModalFormIn
+      { _modalFormIn_headerLabel = _formIn_headerLabel formIn
+      , _modalFormIn_ajax        = _formIn_ajax formIn "/api/income"
+      , _modalFormIn_form        = form reset (_modalFormOut_confirm modalForm)
+      }
+
+  return $ FormOut
+    { _formOut_hide = _modalFormOut_hide modalForm
+    , _formOut_addIncome = _modalFormOut_validate modalForm
+    }
 
   where
-    ajax =
-      case _formIn_httpMethod formIn of
-        Post -> Ajax.post
-        Put  -> Ajax.put
+    form
+      :: Event t String
+      -> Event t ()
+      -> m (Dynamic t (Validation Text a))
+    form reset confirm = do
+      amount <- _inputOut_raw <$> (Component.input
+        (Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Income_Amount
+          , _inputIn_initialValue = _formIn_amount formIn
+          , _inputIn_validation = IncomeValidation.amount
+          })
+        (_formIn_amount formIn <$ reset)
+        confirm)
+
+      let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
+
+      date <- _inputOut_raw <$> (Component.input
+        (Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Income_Date
+          , _inputIn_initialValue = initialDate
+          , _inputIn_inputType = "date"
+          , _inputIn_hasResetButton = False
+          , _inputIn_validation = IncomeValidation.date
+          })
+        (initialDate <$ reset)
+        confirm)
+
+      return $ do
+        a <- amount
+        d <- date
+        return . V.Success $ (_formIn_mkPayload formIn) a d
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 28c0148..163a200 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -17,6 +17,7 @@ import           Common.Model           (Category (..), CreatePaymentForm (..),
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as TimeUtil
 import qualified Component.Modal        as Modal
+import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
 import qualified View.Payment.Form      as Form
 
@@ -45,7 +46,7 @@ view input cancel = do
       , Form._input_category = -1
       , Form._input_frequency = frequency
       , Form._input_mkPayload = CreatePaymentForm
-      , Form._input_httpMethod = Form.Post
+      , Form._input_ajax = Ajax.post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 60694ca..2fa27f3 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -17,6 +17,7 @@ import           Common.Model           (Category (..), CategoryId,
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as TimeUtil
 import qualified Component.Modal        as Modal
+import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
 import qualified View.Payment.Form      as Form
 
@@ -48,7 +49,7 @@ view input cancel = do
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
       , Form._input_mkPayload = CreatePaymentForm
-      , Form._input_httpMethod = Form.Post
+      , Form._input_ajax = Ajax.post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 0361602..77841ce 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -14,6 +14,7 @@ import           Common.Model      (Category (..), CategoryId,
                                     SavedPayment (..))
 import qualified Common.Msg        as Msg
 import qualified Component.Modal   as Modal
+import qualified Util.Ajax         as Ajax
 import qualified Util.Reflex       as ReflexUtil
 import qualified View.Payment.Form as Form
 
@@ -43,7 +44,7 @@ view input cancel = do
       , Form._input_category = category
       , Form._input_frequency = _payment_frequency payment
       , Form._input_mkPayload = EditPaymentForm (_payment_id payment)
-      , Form._input_httpMethod = Form.Put
+      , Form._input_ajax = Ajax.put
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index c817831..1f068fd 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,23 +1,21 @@
 module View.Payment.Form
   ( view
   , Input(..)
-  , HttpMethod(..)
   , Output(..)
   ) where
 
-import           Control.Monad             (join)
-import           Control.Monad.IO.Class    (liftIO)
 import           Data.Aeson                (ToJSON)
 import qualified Data.List                 as L
+import           Data.List.NonEmpty        (NonEmpty)
 import qualified Data.Map                  as M
 import qualified Data.Maybe                as Maybe
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
 import           Data.Time.Calendar        (Day)
 import qualified Data.Time.Calendar        as Calendar
+import           Data.Validation           (Validation)
 import qualified Data.Validation           as V
-import           Reflex.Dom                (Dynamic, Event, MonadHold,
-                                            MonadWidget, Reflex)
+import           Reflex.Dom                (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom                as R
 import qualified Text.Read                 as T
 
@@ -27,16 +25,13 @@ import           Common.Model              (Category (..), CategoryId,
                                             SavedPayment (..))
 import qualified Common.Msg                as Msg
 import qualified Common.Validation.Payment as PaymentValidation
-import           Component                 (ButtonIn (..), InputIn (..),
-                                            InputOut (..), SelectIn (..),
-                                            SelectOut (..))
+import           Component                 (InputIn (..), InputOut (..),
+                                            ModalFormIn (..), ModalFormOut (..),
+                                            SelectIn (..), SelectOut (..))
 import qualified Component                 as Component
-import qualified Util.Ajax                 as Ajax
-import qualified Util.Either               as EitherUtil
 import qualified Util.Validation           as ValidationUtil
-import qualified Util.WaitFor              as WaitFor
 
-data Input t p = Input
+data Input m t a = Input
   { _input_cancel            :: Event t ()
   , _input_headerLabel       :: Text
   , _input_categories        :: [Category]
@@ -46,114 +41,99 @@ data Input t p = Input
   , _input_date              :: Day
   , _input_category          :: CategoryId
   , _input_frequency         :: Frequency
-  , _input_mkPayload         :: Text -> Text -> Text -> CategoryId -> Frequency -> p
-  , _input_httpMethod        :: HttpMethod
+  , _input_mkPayload         :: Text -> Text -> Text -> CategoryId -> Frequency -> a
+  , _input_ajax              :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
   }
 
-data HttpMethod = Put | Post
-
 data Output t = Output
   { _output_hide       :: Event t ()
   , _output_addPayment :: Event t SavedPayment
   }
 
-view :: forall t m p. (MonadWidget t m, ToJSON p) => Input t p -> m (Output t)
+view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t)
 view input = do
-  R.divClass "form" $ do
-    R.divClass "formHeader" $
-      R.text (_input_headerLabel input)
-
-    R.divClass "formContent" $ do
-      rec
-        let reset = R.leftmost
-              [ "" <$ cancel
-              , "" <$ addPayment
-              , "" <$ _input_cancel input
-              ]
-
-        name <- Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Payment_Name
-            , _inputIn_initialValue = _input_name input
-            , _inputIn_validation = PaymentValidation.name
-            })
-          (_input_name input <$ reset)
-          confirm
-
-        cost <- _inputOut_raw <$> (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Payment_Cost
-            , _inputIn_initialValue = _input_cost input
-            , _inputIn_validation = PaymentValidation.cost
-            })
-          (_input_cost input <$ reset)
-          confirm)
-
-        let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
-
-        date <- _inputOut_raw <$> (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.Payment_Date
-            , _inputIn_initialValue = initialDate
-            , _inputIn_inputType = "date"
-            , _inputIn_hasResetButton = False
-            , _inputIn_validation = PaymentValidation.date
-            })
-          (initialDate <$ reset)
-          confirm)
-
-        let setCategory =
-              R.fmapMaybe id . R.updated $
-                R.ffor (_inputOut_raw name) $ \name ->
-                  findCategory name (_input_paymentCategories input)
-
-        category <- _selectOut_value <$> (Component.select $ SelectIn
-          { _selectIn_label = Msg.get Msg.Payment_Category
-          , _selectIn_initialValue = _input_category input
-          , _selectIn_value = setCategory
-          , _selectIn_values = R.constDyn categories
-          , _selectIn_reset = _input_category input <$ reset
-          , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
-          , _selectIn_validate = confirm
-          })
-
-        let payment = do
-              n <- _inputOut_value name
-              c <- cost
-              d <- date
-              cat <- category
-              return ((_input_mkPayload input)
-                <$> ValidationUtil.nelError n
-                <*> V.Success c
-                <*> V.Success d
-                <*> ValidationUtil.nelError cat
-                <*> V.Success (_input_frequency input))
-
-        (addPayment, cancel, confirm) <- R.divClass "buttons" $ do
-          rec
-            cancel <- Component._buttonOut_clic <$> (Component.button $
-              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-                { _buttonIn_class = R.constDyn "undo" })
-
-            confirm <- Component._buttonOut_clic <$> (Component.button $
-              (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
-                { _buttonIn_class = R.constDyn "confirm"
-                , _buttonIn_waiting = waiting
-                , _buttonIn_submit = True
-                })
-
-            (addPayment, waiting) <- WaitFor.waitFor
-              (ajax "/api/payment")
-              (ValidationUtil.fireValidation payment confirm)
-
-          return (R.fmapMaybe EitherUtil.eitherToMaybe addPayment, cancel, confirm)
-
-      return Output
-        { _output_hide = R.leftmost [ cancel, () <$ addPayment ]
-        , _output_addPayment = addPayment
-        }
+  rec
+    let reset = R.leftmost
+          [ "" <$ _modalFormOut_cancel modalForm
+          , "" <$ _modalFormOut_validate modalForm
+          , "" <$ _input_cancel input
+          ]
+
+    modalForm <- Component.modalForm $ ModalFormIn
+      { _modalFormIn_headerLabel = _input_headerLabel input
+      , _modalFormIn_ajax        = _input_ajax input "/api/payment"
+      , _modalFormIn_form        = form reset (_modalFormOut_confirm modalForm)
+      }
+
+  return $ Output
+    { _output_hide = _modalFormOut_hide modalForm
+    , _output_addPayment = _modalFormOut_validate modalForm
+    }
 
   where
+    form
+      :: Event t String
+      -> Event t ()
+      -> m (Dynamic t (Validation (NonEmpty Text) a))
+    form reset confirm = do
+      name <- Component.input
+        (Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Payment_Name
+          , _inputIn_initialValue = _input_name input
+          , _inputIn_validation = PaymentValidation.name
+          })
+        (_input_name input <$ reset)
+        confirm
+
+      cost <- _inputOut_raw <$> (Component.input
+        (Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Payment_Cost
+          , _inputIn_initialValue = _input_cost input
+          , _inputIn_validation = PaymentValidation.cost
+          })
+        (_input_cost input <$ reset)
+        confirm)
+
+      let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
+
+      date <- _inputOut_raw <$> (Component.input
+        (Component.defaultInputIn
+          { _inputIn_label = Msg.get Msg.Payment_Date
+          , _inputIn_initialValue = initialDate
+          , _inputIn_inputType = "date"
+          , _inputIn_hasResetButton = False
+          , _inputIn_validation = PaymentValidation.date
+          })
+        (initialDate <$ reset)
+        confirm)
+
+      let setCategory =
+            R.fmapMaybe id . R.updated $
+              R.ffor (_inputOut_raw name) $ \name ->
+                findCategory name (_input_paymentCategories input)
+
+      category <- _selectOut_value <$> (Component.select $ SelectIn
+        { _selectIn_label = Msg.get Msg.Payment_Category
+        , _selectIn_initialValue = _input_category input
+        , _selectIn_value = setCategory
+        , _selectIn_values = R.constDyn categories
+        , _selectIn_reset = _input_category input <$ reset
+        , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
+        , _selectIn_validate = confirm
+        })
+
+      return $ do
+        n <- _inputOut_value name
+        c <- cost
+        d <- date
+        cat <- category
+        return ((_input_mkPayload input)
+          <$> ValidationUtil.nelError n
+          <*> V.Success c
+          <*> V.Success d
+          <*> ValidationUtil.nelError cat
+          <*> V.Success (_input_frequency input))
+
     frequencies =
       M.fromList
         [ (Punctual, Msg.get Msg.Payment_PunctualMale)
@@ -163,11 +143,6 @@ view input = do
     categories = M.fromList . flip map (_input_categories input) $ \c ->
       (_category_id c, _category_name c)
 
-    ajax =
-      case _input_httpMethod input of
-        Post -> Ajax.post
-        Put  -> Ajax.put
-
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
 findCategory paymentName =
   fmap _paymentCategory_category
-- 
cgit v1.2.3


From 613ffccac4b3ab25c6d4c631fab757da0b35acf6 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 22 Oct 2019 22:26:38 +0200
Subject: Harmonize view component code style

---
 client/src/Component.hs            |  10 ---
 client/src/Component/Button.hs     |  56 ++++++++--------
 client/src/Component/Form.hs       |   6 +-
 client/src/Component/Input.hs      |  79 +++++++++++------------
 client/src/Component/Link.hs       |   6 +-
 client/src/Component/Modal.hs      |  14 ++--
 client/src/Component/ModalForm.hs  |  61 +++++++++---------
 client/src/Component/Pages.hs      |  45 +++++++------
 client/src/Component/Select.hs     |  56 ++++++++--------
 client/src/Component/Table.hs      |  45 +++++++------
 client/src/View/App.hs             |  27 ++++----
 client/src/View/Header.hs          |  82 +++++++++++------------
 client/src/View/Income/Add.hs      |  19 +++---
 client/src/View/Income/Form.hs     |  83 ++++++++++++------------
 client/src/View/Income/Header.hs   |  43 ++++++-------
 client/src/View/Income/Income.hs   |  34 +++++-----
 client/src/View/Income/Table.hs    |  29 ++++-----
 client/src/View/NotFound.hs        |  12 ++--
 client/src/View/Payment/Add.hs     |  40 ++++++------
 client/src/View/Payment/Clone.hs   |  46 ++++++-------
 client/src/View/Payment/Delete.hs  |  57 ++++++++--------
 client/src/View/Payment/Edit.hs    |  46 ++++++-------
 client/src/View/Payment/Form.hs    | 129 ++++++++++++++++++-------------------
 client/src/View/Payment/Header.hs  |  96 ++++++++++++++-------------
 client/src/View/Payment/Pages.hs   |  57 ++++++++--------
 client/src/View/Payment/Payment.hs |  75 +++++++++++----------
 client/src/View/Payment/Table.hs   | 121 +++++++++++++++++-----------------
 client/src/View/SignIn.hs          |  28 ++++----
 28 files changed, 685 insertions(+), 717 deletions(-)
 delete mode 100644 client/src/Component.hs

(limited to 'client/src')

diff --git a/client/src/Component.hs b/client/src/Component.hs
deleted file mode 100644
index fa4e4ea..0000000
--- a/client/src/Component.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Component (module X) where
-
-import           Component.Button    as X
-import           Component.Form      as X
-import           Component.Input     as X
-import           Component.Link      as X
-import           Component.ModalForm as X
-import           Component.Pages     as X
-import           Component.Select    as X
-import           Component.Table     as X
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index b1175d7..6faecef 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -1,8 +1,8 @@
 module Component.Button
-  ( ButtonIn(..)
-  , ButtonOut(..)
-  , button
-  , defaultButtonIn
+  ( In(..)
+  , Out(..)
+  , view
+  , defaultIn
   ) where
 
 import qualified Data.Map   as M
@@ -14,44 +14,44 @@ import qualified Reflex.Dom as R
 
 import qualified View.Icon  as Icon
 
-data ButtonIn t m = ButtonIn
-  { _buttonIn_class    :: Dynamic t Text
-  , _buttonIn_content  :: m ()
-  , _buttonIn_waiting  :: Event t Bool
-  , _buttonIn_tabIndex :: Maybe Int
-  , _buttonIn_submit   :: Bool
+data In t m = In
+  { _in_class    :: Dynamic t Text
+  , _in_content  :: m ()
+  , _in_waiting  :: Event t Bool
+  , _in_tabIndex :: Maybe Int
+  , _in_submit   :: Bool
   }
 
-defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m
-defaultButtonIn content = ButtonIn
-  { _buttonIn_class    = R.constDyn ""
-  , _buttonIn_content  = content
-  , _buttonIn_waiting  = R.never
-  , _buttonIn_tabIndex = Nothing
-  , _buttonIn_submit   = False
+defaultIn :: MonadWidget t m => m () -> In t m
+defaultIn content = In
+  { _in_class    = R.constDyn ""
+  , _in_content  = content
+  , _in_waiting  = R.never
+  , _in_tabIndex = Nothing
+  , _in_submit   = False
   }
 
-data ButtonOut t = ButtonOut
-  { _buttonOut_clic :: Event t ()
+data Out t = Out
+  { _out_clic :: Event t ()
   }
 
-button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
-button buttonIn = do
-  dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn
+view :: forall t m. MonadWidget t m => In t m -> m (Out t)
+view input = do
+  dynWaiting <- R.holdDyn False $ _in_waiting input
 
   let attr = do
-        buttonClass <- _buttonIn_class buttonIn
+        buttonClass <- _in_class input
         waiting <- dynWaiting
         return . M.fromList . catMaybes $
-          [ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button")
-          , (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn
+          [ Just ("type", if _in_submit input then "submit" else "button")
+          , (\i -> ("tabindex", T.pack . show $ i)) <$> _in_tabIndex input
           , Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ])
           ]
 
   (e, _) <- R.elDynAttr' "button" attr $ do
     Icon.loading
-    R.divClass "content" $ _buttonIn_content buttonIn
+    R.divClass "content" $ _in_content input
 
-  return $ ButtonOut
-    { _buttonOut_clic = R.domEvent R.Click e
+  return $ Out
+    { _out_clic = R.domEvent R.Click e
     }
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
index 6ea02fa..6878e68 100644
--- a/client/src/Component/Form.hs
+++ b/client/src/Component/Form.hs
@@ -1,12 +1,12 @@
 module Component.Form
-  ( form
+  ( view
   ) where
 
 import qualified Data.Map   as M
 import           Reflex.Dom (MonadWidget)
 import qualified Reflex.Dom as R
 
-form :: forall t m a. MonadWidget t m => m a -> m a
-form content =
+view :: forall t m a. MonadWidget t m => m a -> m a
+view content =
   R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
     content
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 9ab4d58..37020da 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -1,8 +1,8 @@
 module Component.Input
-  ( InputIn(..)
-  , InputOut(..)
-  , input
-  , defaultInputIn
+  ( In(..)
+  , Out(..)
+  , view
+  , defaultIn
   ) where
 
 import qualified Data.Map               as M
@@ -17,40 +17,39 @@ import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex,
 import qualified Reflex.Dom             as R
 
 import qualified Common.Util.Validation as ValidationUtil
-import           Component.Button       (ButtonIn (..), ButtonOut (..))
 import qualified Component.Button       as Button
 import qualified View.Icon              as Icon
 
-data InputIn a = InputIn
-  { _inputIn_hasResetButton :: Bool
-  , _inputIn_label          :: Text
-  , _inputIn_initialValue   :: Text
-  , _inputIn_inputType      :: Text
-  , _inputIn_validation     :: Text -> Validation Text a
+data In a = In
+  { _in_hasResetButton :: Bool
+  , _in_label          :: Text
+  , _in_initialValue   :: Text
+  , _in_inputType      :: Text
+  , _in_validation     :: Text -> Validation Text a
   }
 
-defaultInputIn :: InputIn Text
-defaultInputIn = InputIn
-  { _inputIn_hasResetButton = True
-  , _inputIn_label          = ""
-  , _inputIn_initialValue   = ""
-  , _inputIn_inputType      = "text"
-  , _inputIn_validation     = V.Success
+defaultIn :: In Text
+defaultIn = In
+  { _in_hasResetButton = True
+  , _in_label          = ""
+  , _in_initialValue   = ""
+  , _in_inputType      = "text"
+  , _in_validation     = V.Success
   }
 
-data InputOut t a = InputOut
-  { _inputOut_raw   :: Dynamic t Text
-  , _inputOut_value :: Dynamic t (Validation Text a)
-  , _inputOut_enter :: Event t ()
+data Out t a = Out
+  { _out_raw   :: Dynamic t Text
+  , _out_value :: Dynamic t (Validation Text a)
+  , _out_enter :: Event t ()
   }
 
-input
+view
   :: forall t m a b. MonadWidget t m
-  => InputIn a
+  => In a
   -> Event t Text -- reset
   -> Event t b    -- validate
-  -> m (InputOut t a)
-input inputIn reset validate = do
+  -> m (Out t a)
+view input reset validate = do
   rec
     let resetValue = R.leftmost
           [ reset
@@ -58,7 +57,7 @@ input inputIn reset validate = do
           ]
 
         inputAttr = R.ffor value (\v ->
-          if T.null v && _inputIn_inputType inputIn /= "date"
+          if T.null v && _in_inputType input /= "date"
             then M.empty
             else M.singleton "class" "filled")
 
@@ -70,7 +69,7 @@ input inputIn reset validate = do
             , if Maybe.isJust e then "error" else ""
             ])
 
-    let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v))
+    let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v))
     inputError <- getInputError valueWithValidation validate
 
     (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
@@ -79,21 +78,21 @@ input inputIn reset validate = do
         textInput <- R.textInput $ R.def
           & R.attributes .~ inputAttr
           & R.setValue .~ resetValue
-          & R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
-          & R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
+          & R.textInputConfig_initialValue .~ (_in_initialValue input)
+          & R.textInputConfig_inputType .~ (_in_inputType input)
 
         R.divClass "label" $
-          R.text (_inputIn_label inputIn)
+          R.text (_in_label input)
 
         return textInput
 
       resetClic <-
-        if _inputIn_hasResetButton inputIn
+        if _in_hasResetButton input
           then
-            _buttonOut_clic <$> (Button.button $
-              (Button.defaultButtonIn Icon.cross)
-                { _buttonIn_class   = R.constDyn "reset"
-                , _buttonIn_tabIndex = Just (-1)
+            Button._out_clic <$> (Button.view $
+              (Button.defaultIn Icon.cross)
+                { Button._in_class   = R.constDyn "reset"
+                , Button._in_tabIndex = Just (-1)
                 })
           else
             return R.never
@@ -105,10 +104,10 @@ input inputIn reset validate = do
 
   let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
 
-  return $ InputOut
-    { _inputOut_raw = value
-    , _inputOut_value = fmap snd valueWithValidation
-    , _inputOut_enter = enter
+  return $ Out
+    { _out_raw = value
+    , _out_value = fmap snd valueWithValidation
+    , _out_enter = enter
     }
 
 getInputError
diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs
index 7e8558b..1fd620e 100644
--- a/client/src/Component/Link.hs
+++ b/client/src/Component/Link.hs
@@ -1,5 +1,5 @@
 module Component.Link
-  ( link
+  ( view
   ) where
 
 import           Data.Map   (Map)
@@ -9,8 +9,8 @@ import qualified Data.Text  as T
 import           Reflex.Dom (Dynamic, MonadWidget)
 import qualified Reflex.Dom as R
 
-link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m ()
-link href inputAttrs content =
+view :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m ()
+view href inputAttrs content =
   R.elDynAttr "a" attrs (R.text content)
   where
 
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 96c2679..50af469 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,5 +1,5 @@
 module Component.Modal
-  ( Input(..)
+  ( In(..)
   , Content
   , view
   ) where
@@ -22,15 +22,15 @@ import qualified Util.Reflex       as ReflexUtil
 -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
 type Content t m a = Event t () -> m (Event t (), Event t a)
 
-data Input t m a = Input
-  { _input_show    :: Event t ()
-  , _input_content :: Content t m a
+data In t m a = In
+  { _in_show    :: Event t ()
+  , _in_content :: Content t m a
   }
 
-view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a)
+view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a)
 view input = do
   rec
-    let show = Show <$ (_input_show input)
+    let show = Show <$ (_in_show input)
 
         startHiding =
           R.attachWithMaybe
@@ -61,7 +61,7 @@ view input = do
           (do
             (curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
             let curtainClick = R.domEvent R.Click curtain
-            (hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick)
+            (hide, content) <- R.divClass "g-Modal__Content" (_in_content input curtainClick)
             return (curtainClick, hide, content))
 
 
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
index 63cb1d2..ea53beb 100644
--- a/client/src/Component/ModalForm.hs
+++ b/client/src/Component/ModalForm.hs
@@ -1,7 +1,7 @@
 module Component.ModalForm
-  ( modalForm
-  , ModalFormIn(..)
-  , ModalFormOut(..)
+  ( view
+  , In(..)
+  , Out(..)
   ) where
 
 import           Data.Aeson         (ToJSON)
@@ -14,57 +14,56 @@ import           Reflex.Dom         (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom         as R
 
 import qualified Common.Msg         as Msg
-import           Component.Button   (ButtonIn (..))
 import qualified Component.Button   as Button
 import qualified Util.Either        as EitherUtil
 import qualified Util.Validation    as ValidationUtil
 import qualified Util.WaitFor       as WaitFor
 
-data ModalFormIn m t a b e = ModalFormIn
-  { _modalFormIn_headerLabel :: Text
-  , _modalFormIn_form        :: m (Dynamic t (Validation e a))
-  , _modalFormIn_ajax        :: Event t a -> m (Event t (Either Text b))
+data In m t a b e = In
+  { _in_headerLabel :: Text
+  , _in_form        :: m (Dynamic t (Validation e a))
+  , _in_ajax        :: Event t a -> m (Event t (Either Text b))
   }
 
-data ModalFormOut t a = ModalFormOut
-  { _modalFormOut_hide     :: Event t ()
-  , _modalFormOut_cancel   :: Event t ()
-  , _modalFormOut_confirm  :: Event t ()
-  , _modalFormOut_validate :: Event t a
+data Out t a = Out
+  { _out_hide     :: Event t ()
+  , _out_cancel   :: Event t ()
+  , _out_confirm  :: Event t ()
+  , _out_validate :: Event t a
   }
 
-modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b)
-modalForm modalFormIn =
+view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b)
+view input =
   R.divClass "form" $ do
     R.divClass "formHeader" $
-      R.text (_modalFormIn_headerLabel modalFormIn)
+      R.text (_in_headerLabel input)
 
     R.divClass "formContent" $ do
       rec
-        form <- _modalFormIn_form modalFormIn
+        form <- _in_form input
 
         (validate, cancel, confirm) <- R.divClass "buttons" $ do
           rec
-            cancel <- Button._buttonOut_clic <$> (Button.button $
-              (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-                { _buttonIn_class = R.constDyn "undo" })
+            cancel <- Button._out_clic <$> (Button.view $
+              (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+                { Button._in_class = R.constDyn "undo" })
 
-            confirm <- Button._buttonOut_clic <$> (Button.button $
-              (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
-                { _buttonIn_class = R.constDyn "confirm"
-                , _buttonIn_waiting = waiting
-                , _buttonIn_submit = True
+            confirm <- Button._out_clic <$> (Button.view $
+              (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
+                { Button._in_class = R.constDyn "confirm"
+                , Button._in_waiting = waiting
+                , Button._in_submit = True
                 })
 
             (validate, waiting) <- WaitFor.waitFor
-              (_modalFormIn_ajax modalFormIn)
+              (_in_ajax input)
               (ValidationUtil.fireValidation form confirm)
 
           return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
 
-      return ModalFormOut
-        { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ]
-        , _modalFormOut_cancel = cancel
-        , _modalFormOut_confirm = confirm
-        , _modalFormOut_validate = validate
+      return Out
+        { _out_hide = R.leftmost [ cancel, () <$ validate ]
+        , _out_cancel = cancel
+        , _out_confirm = confirm
+        , _out_validate = validate
         }
diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
index 7843ef6..7284a36 100644
--- a/client/src/Component/Pages.hs
+++ b/client/src/Component/Pages.hs
@@ -1,41 +1,40 @@
 module Component.Pages
-  ( widget
-  , PagesIn(..)
-  , PagesOut(..)
+  ( view
+  , In(..)
+  , Out(..)
   ) 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 Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
-data PagesIn t = PagesIn
-  { _pagesIn_total   :: Dynamic t Int
-  , _pagesIn_perPage :: Int
-  , _pagesIn_reset   :: Event t ()
+data In t = In
+  { _in_total   :: Dynamic t Int
+  , _in_perPage :: Int
+  , _in_reset   :: Event t ()
   }
 
-data PagesOut t = PagesOut
-  { _pagesOut_currentPage :: Dynamic t Int
+data Out t = Out
+  { _out_currentPage :: Dynamic t Int
   }
 
-widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
-widget pagesIn = do
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
   currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
 
-  return $ PagesOut
-    { _pagesOut_currentPage = currentPage
+  return $ Out
+    { _out_currentPage = currentPage
     }
 
   where
-    total = _pagesIn_total pagesIn
-    perPage = _pagesIn_perPage pagesIn
-    reset = _pagesIn_reset pagesIn
+    total = _in_total input
+    perPage = _in_perPage input
+    reset = _in_reset input
 
 pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
 pageButtons total perPage reset = do
@@ -75,14 +74,14 @@ range currentPage maxPage = [start..end]
 
 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
+  clic <- Button._out_clic <$> (Button.view $ Button.In
+    { Button._in_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
+    , Button._in_content = content
+    , Button._in_waiting = R.never
+    , Button._in_tabIndex = Nothing
+    , Button._in_submit = False
     })
   return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 102f554..375ae06 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -1,7 +1,7 @@
 module Component.Select
-  ( SelectIn(..)
-  , SelectOut(..)
-  , select
+  ( view
+  , In(..)
+  , Out(..)
   ) where
 
 import           Data.Map        (Map)
@@ -15,58 +15,58 @@ import qualified Reflex.Dom      as R
 
 import qualified Util.Validation as ValidationUtil
 
-data (Reflex t) => SelectIn t a b c = SelectIn
-  { _selectIn_label        :: Text
-  , _selectIn_initialValue :: a
-  , _selectIn_value        :: Event t a
-  , _selectIn_values       :: Dynamic t (Map a Text)
-  , _selectIn_reset        :: Event t b
-  , _selectIn_isValid      :: a -> Validation Text a
-  , _selectIn_validate     :: Event t c
+data (Reflex t) => In t a b c = In
+  { _in_label        :: Text
+  , _in_initialValue :: a
+  , _in_value        :: Event t a
+  , _in_values       :: Dynamic t (Map a Text)
+  , _in_reset        :: Event t b
+  , _in_isValid      :: a -> Validation Text a
+  , _in_validate     :: Event t c
   }
 
-data SelectOut t a = SelectOut
-  { _selectOut_raw   :: Dynamic t a
-  , _selectOut_value :: Dynamic t (Validation Text a)
+data Out t a = Out
+  { _out_raw   :: Dynamic t a
+  , _out_value :: Dynamic t (Validation Text a)
   }
 
-select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a)
-select selectIn = do
+view :: forall t m a b c. (Ord a, MonadWidget t m) => In t a b c -> m (Out t a)
+view input = do
   rec
     let containerAttr = R.ffor showedError (\e ->
           M.singleton "class" $ T.intercalate " "
-            [ "selectInput"
+            [ "input"
             , if Maybe.isJust e then "error" else ""
             ])
 
         validatedValue =
-          fmap (_selectIn_isValid selectIn) value
+          fmap (_in_isValid input) value
 
         maybeError =
           fmap ValidationUtil.maybeError validatedValue
 
     showedError <- R.holdDyn Nothing $ R.leftmost
-      [ Nothing <$ _selectIn_reset selectIn
+      [ Nothing <$ _in_reset input
       , R.updated maybeError
-      , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
+      , R.attachWith const (R.current maybeError) (_in_validate input)
       ]
 
     value <- R.elDynAttr "div" containerAttr $ do
-      let initialValue = _selectIn_initialValue selectIn
+      let initialValue = _in_initialValue input
 
       let setValue = R.leftmost
-            [ initialValue <$ (_selectIn_reset selectIn)
-            , _selectIn_value selectIn
+            [ initialValue <$ (_in_reset input)
+            , _in_value input
             ]
 
       value <- R.el "label" $ do
         R.divClass "label" $
-          R.text (_selectIn_label selectIn)
+          R.text (_in_label input)
 
         R._dropdown_value <$>
           R.dropdown
             initialValue
-            (_selectIn_values selectIn)
+            (_in_values input)
             (R.def { R._dropdownConfig_setValue = setValue })
 
       R.divClass "errorMessage" . R.dynText $
@@ -74,7 +74,7 @@ select selectIn = do
 
       return value
 
-  return SelectOut
-    { _selectOut_raw = value
-    , _selectOut_value = validatedValue
+  return Out
+    { _out_raw = value
+    , _out_value = validatedValue
     }
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index b431c14..bf76566 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -1,29 +1,28 @@
 module Component.Table
-  ( table
-  , TableIn(..)
-  , TableOut(..)
+  ( view
+  , In(..)
+  , Out(..)
   ) where
 
 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 In h r t = In
+  { _in_headerLabel :: h -> Text
+  , _in_rows        :: Dynamic t [r]
+  , _in_cell        :: h -> r -> Text
+  , _in_perPage     :: Int
+  , _in_resetPage   :: Event t ()
   }
 
-data TableOut = TableOut
+data Out = Out
   {}
 
-table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h)  => TableIn h r t -> m (TableOut)
-table tableIn =
+view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h)  => In h r t -> m (Out)
+view input =
   R.divClass "table" $ do
     rec
       R.divClass "lines" $ do
@@ -31,29 +30,29 @@ table tableIn =
         R.divClass "header" $
           flip mapM_ [minBound..] $ \header ->
             R.divClass "cell" . R.text $
-              _tableIn_headerLabel tableIn header
+              _in_headerLabel input header
 
         let rows = getRange
-              (_tableIn_perPage tableIn)
-                <$> (_pagesOut_currentPage pages)
-                <*> (_tableIn_rows tableIn)
+              (_in_perPage input)
+                <$> (Pages._out_currentPage pages)
+                <*> (_in_rows input)
 
         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.ffor r (_in_cell input h)
 
-      pages <- Pages.widget $ PagesIn
-        { _pagesIn_total = length <$> (_tableIn_rows tableIn)
-        , _pagesIn_perPage = _tableIn_perPage tableIn
-        , _pagesIn_reset = _tableIn_resetPage tableIn
+      pages <- Pages.view $ Pages.In
+        { Pages._in_total = length <$> (_in_rows input)
+        , Pages._in_perPage = _in_perPage input
+        , Pages._in_reset = _in_resetPage input
         }
 
       return ()
 
-    return $ TableOut
+    return $ Out
       {}
 
 getRange :: forall a. Int -> Int -> [a] -> [a]
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index b468e56..e0a52e2 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -13,12 +13,9 @@ import qualified Common.Msg           as Msg
 
 import           Model.Route          (Route (..))
 import qualified Util.Router          as Router
-import           View.Header          (HeaderIn (..))
 import qualified View.Header          as Header
-import           View.Income.Income   (IncomeIn (..))
 import qualified View.Income.Income   as Income
 import qualified View.NotFound        as NotFound
-import           View.Payment.Payment (PaymentIn (..))
 import qualified View.Payment.Payment as Payment
 import qualified View.SignIn          as SignIn
 
@@ -28,17 +25,17 @@ widget initResult =
 
     route <- getRoute
 
-    headerOut <- Header.view $ HeaderIn
-      { _headerIn_initResult = initResult
-      , _headerIn_isInitSuccess =
+    header <- Header.view $ Header.In
+      { Header._in_initResult = initResult
+      , Header._in_isInitSuccess =
         case initResult of
           InitSuccess _ -> True
           _             -> False
-      , _headerIn_route = route
+      , Header._in_route = route
       }
 
     let signOut =
-          Header._headerOut_signOut headerOut
+          Header._out_signOut header
 
         mainContent =
           case initResult of
@@ -63,17 +60,17 @@ signedWidget init route = do
   R.dyn . R.ffor route $ \case
     RootRoute -> do
       paymentInit <- Payment.init
-      Payment.view $ PaymentIn
-        { _paymentIn_currentUser = _init_currentUser init
-        , _paymentIn_currency = _init_currency init
-        , _paymentIn_init = paymentInit
+      Payment.view $ Payment.In
+        { Payment._in_currentUser = _init_currentUser init
+        , Payment._in_currency = _init_currency init
+        , Payment._in_init = paymentInit
         }
 
     IncomeRoute -> do
       incomeInit <- Income.init
-      Income.view $ IncomeIn
-        { _incomeIn_currency = _init_currency init
-        , _incomeIn_init = incomeInit
+      Income.view $ Income.In
+        { Income._in_currency = _init_currency init
+        , Income._in_init = incomeInit
         }
 
     NotFoundRoute ->
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 68329eb..3f58dd5 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -1,40 +1,40 @@
 module View.Header
   ( view
-  , HeaderIn(..)
-  , HeaderOut(..)
+  , In(..)
+  , Out(..)
   ) where
 
-import           Data.Map     (Map)
-import qualified Data.Map     as M
-import           Data.Text    (Text)
-import qualified Data.Text    as T
-import           Data.Time    (NominalDiffTime)
-import           Prelude      hiding (error, init)
-import           Reflex.Dom   (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom   as R
-
-import           Common.Model (Init (..), InitResult (..), User (..))
-import qualified Common.Model as CM
-import qualified Common.Msg   as Msg
-import           Component    (ButtonIn (..))
-import qualified Component    as Component
-import           Model.Route  (Route (..))
-import qualified Util.Css     as CssUtil
-import qualified Util.Reflex  as ReflexUtil
-import qualified View.Icon    as Icon
-
-data HeaderIn t = HeaderIn
-  { _headerIn_initResult    :: InitResult
-  , _headerIn_isInitSuccess :: Bool
-  , _headerIn_route         :: Dynamic t Route
+import           Data.Map         (Map)
+import qualified Data.Map         as M
+import           Data.Text        (Text)
+import qualified Data.Text        as T
+import           Data.Time        (NominalDiffTime)
+import           Prelude          hiding (error, init)
+import           Reflex.Dom       (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom       as R
+
+import           Common.Model     (Init (..), InitResult (..), User (..))
+import qualified Common.Model     as CM
+import qualified Common.Msg       as Msg
+import qualified Component.Button as Button
+import qualified Component.Link   as Link
+import           Model.Route      (Route (..))
+import qualified Util.Css         as CssUtil
+import qualified Util.Reflex      as ReflexUtil
+import qualified View.Icon        as Icon
+
+data In t = In
+  { _in_initResult    :: InitResult
+  , _in_isInitSuccess :: Bool
+  , _in_route         :: Dynamic t Route
   }
 
-data HeaderOut t = HeaderOut
-  { _headerOut_signOut :: Event t ()
+data Out t = Out
+  { _out_signOut :: Event t ()
   }
 
-view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t)
-view headerIn =
+view :: forall t m. MonadWidget t m => (In t) -> m (Out t)
+view input =
   R.el "header" $ do
 
     R.divClass "title" $
@@ -42,23 +42,23 @@ view headerIn =
 
     signOut <- R.el "div" $ do
       rec
-        showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut)
-        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn)
-        signOut <- nameSignOut $ _headerIn_initResult headerIn
+        showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut)
+        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
+        signOut <- nameSignOut $ _in_initResult input
       return signOut
 
-    return $ HeaderOut
-      { _headerOut_signOut = signOut
+    return $ Out
+      { _out_signOut = signOut
       }
 
 links :: forall t m. MonadWidget t m => Dynamic t Route -> m ()
 links route = do
-  Component.link
+  Link.view
     "/"
     (R.ffor route (attrs RootRoute))
     (Msg.get Msg.Payment_Title)
 
-  Component.link
+  Link.view
     "/income"
     (R.ffor route (attrs IncomeRoute))
     (Msg.get Msg.Income_Title)
@@ -92,12 +92,12 @@ nameSignOut initResult = case initResult of
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
   rec
-    signOut <- Component.button $
-      (Component.defaultButtonIn Icon.signOut)
-        { _buttonIn_class = R.constDyn "signOut item"
-        , _buttonIn_waiting = waiting
+    signOut <- Button.view $
+      (Button.defaultIn Icon.signOut)
+        { Button._in_class = R.constDyn "signOut item"
+        , Button._in_waiting = waiting
         }
-    let signOutClic = Component._buttonOut_clic signOut
+    let signOutClic = Button._out_clic signOut
         waiting = R.leftmost
           [ fmap (const True) signOutClic
           , fmap (const False) signOutSuccess
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
index 0b1bd04..f8f107f 100644
--- a/client/src/View/Income/Add.hs
+++ b/client/src/View/Income/Add.hs
@@ -13,7 +13,6 @@ import qualified Common.Util.Time       as TimeUtil
 import qualified Component.Modal        as Modal
 import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
-import           View.Income.Form       (FormIn (..), FormOut (..))
 import qualified View.Income.Form       as Form
 
 view :: forall t m. MonadWidget t m => Modal.Content t m Income
@@ -22,16 +21,16 @@ view cancel = do
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
   form <- R.dyn $
-    return $ Form.view $ FormIn
-      { _formIn_cancel = cancel
-      , _formIn_headerLabel = Msg.get Msg.Income_AddLong
-      , _formIn_amount = ""
-      , _formIn_date = currentDay
-      , _formIn_mkPayload = CreateIncomeForm
-      , _formIn_ajax = Ajax.post
+    return $ Form.view $ Form.In
+      { Form._in_cancel = cancel
+      , Form._in_headerLabel = Msg.get Msg.Income_AddLong
+      , Form._in_amount = ""
+      , Form._in_date = currentDay
+      , Form._in_mkPayload = CreateIncomeForm
+      , Form._in_ajax = Ajax.post
       }
 
-  hide <- ReflexUtil.flatten (_formOut_hide <$> form)
-  addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form)
+  hide <- ReflexUtil.flatten (Form._out_hide <$> form)
+  addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form)
 
   return (hide, addIncome)
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index 824bb0a..917edf1 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -1,7 +1,7 @@
 module View.Income.Form
   ( view
-  , FormIn(..)
-  , FormOut(..)
+  , In(..)
+  , Out(..)
   ) where
 
 import           Data.Aeson               (FromJSON, ToJSON)
@@ -17,42 +17,41 @@ import qualified Reflex.Dom               as R
 import           Common.Model             (Income)
 import qualified Common.Msg               as Msg
 import qualified Common.Validation.Income as IncomeValidation
-import           Component                (InputIn (..), InputOut (..),
-                                           ModalFormIn (..), ModalFormOut (..))
-import qualified Component                as Component
+import qualified Component.Input          as Input
+import qualified Component.ModalForm      as ModalForm
 
-data FormIn m t a = FormIn
-  { _formIn_cancel      :: Event t ()
-  , _formIn_headerLabel :: Text
-  , _formIn_amount      :: Text
-  , _formIn_date        :: Day
-  , _formIn_mkPayload   :: Text -> Text -> a
-  , _formIn_ajax        :: Text -> Event t a -> m (Event t (Either Text Income))
+data In m t a = In
+  { _in_cancel      :: Event t ()
+  , _in_headerLabel :: Text
+  , _in_amount      :: Text
+  , _in_date        :: Day
+  , _in_mkPayload   :: Text -> Text -> a
+  , _in_ajax        :: Text -> Event t a -> m (Event t (Either Text Income))
   }
 
-data FormOut t = FormOut
-  { _formOut_hide      :: Event t ()
-  , _formOut_addIncome :: Event t Income
+data Out t = Out
+  { _out_hide      :: Event t ()
+  , _out_addIncome :: Event t Income
   }
 
-view :: forall t m a. (MonadWidget t m, ToJSON a) => FormIn m t a -> m (FormOut t)
-view formIn = do
+view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t)
+view input = do
   rec
     let reset = R.leftmost
-          [ "" <$ _modalFormOut_cancel modalForm
-          , "" <$ _modalFormOut_validate modalForm
-          , "" <$ _formIn_cancel formIn
+          [ "" <$ ModalForm._out_cancel modalForm
+          , "" <$ ModalForm._out_validate modalForm
+          , "" <$ _in_cancel input
           ]
 
-    modalForm <- Component.modalForm $ ModalFormIn
-      { _modalFormIn_headerLabel = _formIn_headerLabel formIn
-      , _modalFormIn_ajax        = _formIn_ajax formIn "/api/income"
-      , _modalFormIn_form        = form reset (_modalFormOut_confirm modalForm)
+    modalForm <- ModalForm.view $ ModalForm.In
+      { ModalForm._in_headerLabel = _in_headerLabel input
+      , ModalForm._in_ajax        = _in_ajax input "/api/income"
+      , ModalForm._in_form        = form reset (ModalForm._out_confirm modalForm)
       }
 
-  return $ FormOut
-    { _formOut_hide = _modalFormOut_hide modalForm
-    , _formOut_addIncome = _modalFormOut_validate modalForm
+  return $ Out
+    { _out_hide = ModalForm._out_hide modalForm
+    , _out_addIncome = ModalForm._out_validate modalForm
     }
 
   where
@@ -61,24 +60,24 @@ view formIn = do
       -> Event t ()
       -> m (Dynamic t (Validation Text a))
     form reset confirm = do
-      amount <- _inputOut_raw <$> (Component.input
-        (Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Income_Amount
-          , _inputIn_initialValue = _formIn_amount formIn
-          , _inputIn_validation = IncomeValidation.amount
+      amount <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Income_Amount
+          , Input._in_initialValue = _in_amount input
+          , Input._in_validation = IncomeValidation.amount
           })
-        (_formIn_amount formIn <$ reset)
+        (_in_amount input <$ reset)
         confirm)
 
-      let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
+      let initialDate = T.pack . Calendar.showGregorian . _in_date $ input
 
-      date <- _inputOut_raw <$> (Component.input
-        (Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Income_Date
-          , _inputIn_initialValue = initialDate
-          , _inputIn_inputType = "date"
-          , _inputIn_hasResetButton = False
-          , _inputIn_validation = IncomeValidation.date
+      date <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Income_Date
+          , Input._in_initialValue = initialDate
+          , Input._in_inputType = "date"
+          , Input._in_hasResetButton = False
+          , Input._in_validation = IncomeValidation.date
           })
         (initialDate <$ reset)
         confirm)
@@ -86,4 +85,4 @@ view formIn = do
       return $ do
         a <- amount
         d <- date
-        return . V.Success $ (_formIn_mkPayload formIn) a d
+        return . V.Success $ (_in_mkPayload input) a d
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 4e08955..ae1174a 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -1,7 +1,7 @@
 module View.Income.Header
   ( view
-  , HeaderIn(..)
-  , HeaderOut(..)
+  , In(..)
+  , Out(..)
   ) where
 
 import           Control.Monad.IO.Class (liftIO)
@@ -16,25 +16,24 @@ import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
 
-import           Component              (ButtonOut (..))
-import qualified Component
+import qualified Component.Button       as Button
 import qualified Component.Modal        as Modal
 import qualified Util.Date              as DateUtil
 import qualified View.Income.Add        as Add
 import           View.Income.Init       (Init (..))
 
-data HeaderIn t = HeaderIn
-  { _headerIn_init     :: Init
-  , _headerIn_currency :: Currency
-  , _headerIn_incomes  :: Dynamic t [Income]
+data In t = In
+  { _in_init     :: Init
+  , _in_currency :: Currency
+  , _in_incomes  :: Dynamic t [Income]
   }
 
-data HeaderOut t = HeaderOut
-  { _headerOut_addIncome :: Event t Income
+data Out t = Out
+  { _out_addIncome :: Event t Income
   }
 
-view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
-view headerIn =
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input =
   R.divClass "withMargin" $ do
 
     currentTime <- liftIO Clock.getCurrentTime
@@ -58,7 +57,7 @@ view headerIn =
                   T.intercalate " "
                     [ _user_name user
                     , "−"
-                    , Format.price (_headerIn_currency headerIn) $
+                    , Format.price (_in_currency input) $
                       CM.cumulativeIncomesSince currentTime since userIncomes
                     ]
 
@@ -67,23 +66,23 @@ view headerIn =
         R.text $
           Msg.get Msg.Income_MonthlyNet
 
-      addIncome <- _buttonOut_clic <$>
-        (Component.button . Component.defaultButtonIn . R.text $
+      addIncome <- Button._out_clic <$>
+        (Button.view . Button.defaultIn . R.text $
           Msg.get Msg.Income_AddLong)
 
-      addIncome <- Modal.view $ Modal.Input
-        { Modal._input_show    = addIncome
-        , Modal._input_content = Add.view
+      addIncome <- Modal.view $ Modal.In
+        { Modal._in_show    = addIncome
+        , Modal._in_content = Add.view
         }
 
-      return $ HeaderOut
-        { _headerOut_addIncome = addIncome
+      return $ Out
+        { _out_addIncome = addIncome
         }
 
   where
-    init = _headerIn_init headerIn
+    init = _in_init input
 
-    useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes ->
+    useIncomesFrom = R.ffor (_in_incomes input) $ \incomes ->
       ( CM.useIncomesFrom
         (map _user_id $_init_users init)
         incomes
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 18ebe7c..f8359bb 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -1,7 +1,7 @@
 module View.Income.Income
   ( init
   , view
-  , IncomeIn(..)
+  , In(..)
   ) where
 
 import           Data.Aeson         (FromJSON)
@@ -14,15 +14,13 @@ import           Common.Model       (Currency)
 import           Loadable           (Loadable (..))
 import qualified Loadable
 import qualified Util.Ajax          as AjaxUtil
-import           View.Income.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Income.Header as Header
 import           View.Income.Init   (Init (..))
-import           View.Income.Table  (IncomeTableIn (..))
 import qualified View.Income.Table  as Table
 
-data IncomeIn t = IncomeIn
-  { _incomeIn_currency :: Currency
-  , _incomeIn_init     :: Dynamic t (Loadable Init)
+data In t = In
+  { _in_currency :: Currency
+  , _in_init     :: Dynamic t (Loadable Init)
   }
 
 init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
@@ -36,9 +34,9 @@ init = do
     ps <- payments
     return $ Init <$> us <*> is <*> ps
 
-view :: forall t m. MonadWidget t m => IncomeIn t -> m ()
-view incomeIn = do
-  R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init ->
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input = do
+  R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
 
     R.elClass "main" "income" $ do
 
@@ -47,18 +45,18 @@ view incomeIn = do
         incomes <- R.foldDyn
           (:)
           (_init_incomes init)
-          (_headerOut_addIncome header)
+          (Header._out_addIncome header)
 
-        header <- Header.view $ HeaderIn
-          { _headerIn_init = init
-          , _headerIn_currency = _incomeIn_currency incomeIn
-          , _headerIn_incomes = incomes
+        header <- Header.view $ Header.In
+          { Header._in_init = init
+          , Header._in_currency = _in_currency input
+          , Header._in_incomes = incomes
           }
 
-      Table.view $ IncomeTableIn
-        { _tableIn_init = init
-        , _tableIn_currency = _incomeIn_currency incomeIn
-        , _tableIn_incomes = incomes
+      Table.view $ Table.In
+        { Table._in_init = init
+        , Table._in_currency = _in_currency input
+        , Table._in_incomes = incomes
         }
 
       return ()
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index d42848b..9cb705f 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -1,6 +1,6 @@
 module View.Income.Table
   ( view
-  , IncomeTableIn(..)
+  , In(..)
   ) where
 
 import qualified Data.List          as L
@@ -14,25 +14,24 @@ import qualified Common.Model       as CM
 import qualified Common.Msg         as Msg
 import qualified Common.View.Format as Format
 
-import           Component          (TableIn (..))
-import qualified Component
+import qualified Component.Table    as Table
 import           View.Income.Init   (Init (..))
 
-data IncomeTableIn t = IncomeTableIn
-  { _tableIn_init     :: Init
-  , _tableIn_currency :: Currency
-  , _tableIn_incomes  :: Dynamic t [Income]
+data In t = In
+  { _in_init     :: Init
+  , _in_currency :: Currency
+  , _in_incomes  :: Dynamic t [Income]
   }
 
-view :: forall t m. MonadWidget t m => IncomeTableIn t -> m ()
-view tableIn = do
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input = do
 
-    Component.table $ TableIn
-      { _tableIn_headerLabel = headerLabel
-      , _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date
-      , _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn)
-      , _tableIn_perPage = 7
-      , _tableIn_resetPage = R.never
+    Table.view $ Table.In
+      { Table._in_headerLabel = headerLabel
+      , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
+      , Table._in_cell = cell (_in_init input) (_in_currency input)
+      , Table._in_perPage = 7
+      , Table._in_resetPage = R.never
       }
 
     return ()
diff --git a/client/src/View/NotFound.hs b/client/src/View/NotFound.hs
index 1d4e477..1597849 100644
--- a/client/src/View/NotFound.hs
+++ b/client/src/View/NotFound.hs
@@ -2,19 +2,19 @@ module View.NotFound
   ( view
   ) where
 
-import qualified Data.Map   as M
-import           Reflex.Dom (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom as R
+import qualified Data.Map       as M
+import           Reflex.Dom     (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom     as R
 
-import qualified Common.Msg as Msg
-import qualified Component  as Component
+import qualified Common.Msg     as Msg
+import qualified Component.Link as Link
 
 view :: forall t m. MonadWidget t m => m ()
 view =
   R.divClass "notfound" $ do
     R.text (Msg.get Msg.NotFound_Message)
 
-    Component.link
+    Link.view
       "/"
       (R.constDyn $ M.singleton "class" "link")
       (Msg.get Msg.NotFound_LinkMessage)
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
index 163a200..e983465 100644
--- a/client/src/View/Payment/Add.hs
+++ b/client/src/View/Payment/Add.hs
@@ -1,6 +1,6 @@
 module View.Payment.Add
   ( view
-  , Input(..)
+  , In(..)
   ) where
 
 import           Control.Monad          (join)
@@ -21,32 +21,32 @@ import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
 import qualified View.Payment.Form      as Form
 
-data Input t = Input
-  { _input_categories        :: [Category]
-  , _input_paymentCategories :: Dynamic t [PaymentCategory]
-  , _input_frequency         :: Dynamic t Frequency
+data In t = In
+  { _in_categories        :: [Category]
+  , _in_paymentCategories :: Dynamic t [PaymentCategory]
+  , _in_frequency         :: Dynamic t Frequency
   }
 
-view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
 view input cancel = do
 
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
   formOutput <- R.dyn $ do
-    paymentCategories <- _input_paymentCategories input
-    frequency <- _input_frequency input
-    return $ Form.view $ Form.Input
-      { Form._input_cancel = cancel
-      , Form._input_headerLabel = Msg.get Msg.Payment_Add
-      , Form._input_categories = _input_categories input
-      , Form._input_paymentCategories = paymentCategories
-      , Form._input_name = ""
-      , Form._input_cost = ""
-      , Form._input_date = currentDay
-      , Form._input_category = -1
-      , Form._input_frequency = frequency
-      , Form._input_mkPayload = CreatePaymentForm
-      , Form._input_ajax = Ajax.post
+    paymentCategories <- _in_paymentCategories input
+    frequency <- _in_frequency input
+    return $ Form.view $ Form.In
+      { Form._in_cancel = cancel
+      , Form._in_headerLabel = Msg.get Msg.Payment_Add
+      , Form._in_categories = _in_categories input
+      , Form._in_paymentCategories = paymentCategories
+      , Form._in_name = ""
+      , Form._in_cost = ""
+      , Form._in_date = currentDay
+      , Form._in_category = -1
+      , Form._in_frequency = frequency
+      , Form._in_mkPayload = CreatePaymentForm
+      , Form._in_ajax = Ajax.post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 2fa27f3..56a33d9 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -1,5 +1,5 @@
 module View.Payment.Clone
-  ( Input(..)
+  ( In(..)
   , view
   ) where
 
@@ -21,35 +21,35 @@ import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
 import qualified View.Payment.Form      as Form
 
-data Input t = Input
-  { _input_show              :: Event t ()
-  , _input_categories        :: [Category]
-  , _input_paymentCategories :: Dynamic t [PaymentCategory]
-  , _input_payment           :: Dynamic t Payment
-  , _input_category          :: Dynamic t CategoryId
+data In t = In
+  { _in_show              :: Event t ()
+  , _in_categories        :: [Category]
+  , _in_paymentCategories :: Dynamic t [PaymentCategory]
+  , _in_payment           :: Dynamic t Payment
+  , _in_category          :: Dynamic t CategoryId
   }
 
-view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
 view input cancel = do
 
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
   formOutput <- R.dyn $ do
-    paymentCategories <- _input_paymentCategories input
-    payment <- _input_payment input
-    category <- _input_category input
-    return . Form.view $ Form.Input
-      { Form._input_cancel = cancel
-      , Form._input_headerLabel = Msg.get Msg.Payment_CloneLong
-      , Form._input_categories = _input_categories input
-      , Form._input_paymentCategories = paymentCategories
-      , Form._input_name = _payment_name payment
-      , Form._input_cost = T.pack . show . _payment_cost $ payment
-      , Form._input_date = currentDay
-      , Form._input_category = category
-      , Form._input_frequency = _payment_frequency payment
-      , Form._input_mkPayload = CreatePaymentForm
-      , Form._input_ajax = Ajax.post
+    paymentCategories <- _in_paymentCategories input
+    payment <- _in_payment input
+    category <- _in_category input
+    return . Form.view $ Form.In
+      { Form._in_cancel = cancel
+      , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong
+      , Form._in_categories = _in_categories input
+      , Form._in_paymentCategories = paymentCategories
+      , Form._in_name = _payment_name payment
+      , Form._in_cost = T.pack . show . _payment_cost $ payment
+      , Form._in_date = currentDay
+      , Form._in_category = category
+      , Form._in_frequency = _payment_frequency payment
+      , Form._in_mkPayload = CreatePaymentForm
+      , Form._in_ajax = Ajax.post
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index dc7e395..471463c 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -1,28 +1,27 @@
 module View.Payment.Delete
-  ( Input(..)
+  ( In(..)
   , view
   ) where
 
-import           Data.Text       (Text)
-import qualified Data.Text       as T
-import           Reflex.Dom      (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom      as R
-
-import           Common.Model    (Payment (..))
-import qualified Common.Msg      as Msg
-import           Component       (ButtonIn (..), ButtonOut (..))
-import qualified Component       as Component
-import qualified Component.Modal as Modal
-import qualified Component.Modal as Modal
-import qualified Util.Ajax       as Ajax
-import qualified Util.Either     as EitherUtil
-import qualified Util.WaitFor    as WaitFor
-
-data Input t = Input
-  { _input_payment :: Dynamic t Payment
+import           Data.Text        (Text)
+import qualified Data.Text        as T
+import           Reflex.Dom       (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom       as R
+
+import           Common.Model     (Payment (..))
+import qualified Common.Msg       as Msg
+import qualified Component.Button as Button
+import qualified Component.Modal  as Modal
+import qualified Component.Modal  as Modal
+import qualified Util.Ajax        as Ajax
+import qualified Util.Either      as EitherUtil
+import qualified Util.WaitFor     as WaitFor
+
+data In t = In
+  { _in_payment :: Dynamic t Payment
   }
 
-view :: forall t m. MonadWidget t m => (Input t) -> Modal.Content t m Payment
+view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment
 view input _ =
   R.divClass "delete" $ do
     R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
@@ -31,20 +30,20 @@ view input _ =
 
       (confirm, cancel) <- R.divClass "buttons" $ do
 
-        cancel <- Component._buttonOut_clic <$> (Component.button $
-          (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
-            { _buttonIn_class = R.constDyn "undo" })
+        cancel <- Button._out_clic <$> (Button.view $
+          (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { Button._in_class = R.constDyn "undo" })
 
         rec
-          confirm <- Component._buttonOut_clic <$> (Component.button $
-            (Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
-              { _buttonIn_class = R.constDyn "confirm"
-              , _buttonIn_submit = True
-              , _buttonIn_waiting = waiting
+          confirm <- Button._out_clic <$> (Button.view $
+            (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { Button._in_class = R.constDyn "confirm"
+              , Button._in_submit = True
+              , Button._in_waiting = waiting
               })
 
           let url =
-                R.ffor (_input_payment input) (\id ->
+                R.ffor (_in_payment input) (\id ->
                   T.concat ["/api/payment/", T.pack . show $ _payment_id id]
                 )
 
@@ -56,5 +55,5 @@ view input _ =
 
       return $
         ( R.leftmost [ cancel, () <$ confirm ]
-        , R.tag (R.current $ _input_payment input) confirm
+        , R.tag (R.current $ _in_payment input) confirm
         )
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
index 77841ce..5cb4537 100644
--- a/client/src/View/Payment/Edit.hs
+++ b/client/src/View/Payment/Edit.hs
@@ -1,5 +1,5 @@
 module View.Payment.Edit
-  ( Input(..)
+  ( In(..)
   , view
   ) where
 
@@ -18,33 +18,33 @@ import qualified Util.Ajax         as Ajax
 import qualified Util.Reflex       as ReflexUtil
 import qualified View.Payment.Form as Form
 
-data Input t = Input
-  { _input_show              :: Event t ()
-  , _input_categories        :: [Category]
-  , _input_paymentCategories :: Dynamic t [PaymentCategory]
-  , _input_payment           :: Dynamic t Payment
-  , _input_category          :: Dynamic t CategoryId
+data In t = In
+  { _in_show              :: Event t ()
+  , _in_categories        :: [Category]
+  , _in_paymentCategories :: Dynamic t [PaymentCategory]
+  , _in_payment           :: Dynamic t Payment
+  , _in_category          :: Dynamic t CategoryId
   }
 
-view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
+view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
 view input cancel = do
 
   formOutput <- R.dyn $ do
-    paymentCategories <- _input_paymentCategories input
-    payment <- _input_payment input
-    category <- _input_category input
-    return . Form.view $ Form.Input
-      { Form._input_cancel = cancel
-      , Form._input_headerLabel = Msg.get Msg.Payment_EditLong
-      , Form._input_categories = _input_categories input
-      , Form._input_paymentCategories = paymentCategories
-      , Form._input_name = _payment_name payment
-      , Form._input_cost = T.pack . show . _payment_cost $ payment
-      , Form._input_date = _payment_date payment
-      , Form._input_category = category
-      , Form._input_frequency = _payment_frequency payment
-      , Form._input_mkPayload = EditPaymentForm (_payment_id payment)
-      , Form._input_ajax = Ajax.put
+    paymentCategories <- _in_paymentCategories input
+    payment <- _in_payment input
+    category <- _in_category input
+    return . Form.view $ Form.In
+      { Form._in_cancel = cancel
+      , Form._in_headerLabel = Msg.get Msg.Payment_EditLong
+      , Form._in_categories = _in_categories input
+      , Form._in_paymentCategories = paymentCategories
+      , Form._in_name = _payment_name payment
+      , Form._in_cost = T.pack . show . _payment_cost $ payment
+      , Form._in_date = _payment_date payment
+      , Form._in_category = category
+      , Form._in_frequency = _payment_frequency payment
+      , Form._in_mkPayload = EditPaymentForm (_payment_id payment)
+      , Form._in_ajax = Ajax.put
       }
 
   hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 1f068fd..29768aa 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,7 +1,7 @@
 module View.Payment.Form
   ( view
-  , Input(..)
-  , Output(..)
+  , In(..)
+  , Out(..)
   ) where
 
 import           Data.Aeson                (ToJSON)
@@ -25,49 +25,48 @@ import           Common.Model              (Category (..), CategoryId,
                                             SavedPayment (..))
 import qualified Common.Msg                as Msg
 import qualified Common.Validation.Payment as PaymentValidation
-import           Component                 (InputIn (..), InputOut (..),
-                                            ModalFormIn (..), ModalFormOut (..),
-                                            SelectIn (..), SelectOut (..))
-import qualified Component                 as Component
+import qualified Component.Input           as Input
+import qualified Component.ModalForm       as ModalForm
+import qualified Component.Select          as Select
 import qualified Util.Validation           as ValidationUtil
 
-data Input m t a = Input
-  { _input_cancel            :: Event t ()
-  , _input_headerLabel       :: Text
-  , _input_categories        :: [Category]
-  , _input_paymentCategories :: [PaymentCategory]
-  , _input_name              :: Text
-  , _input_cost              :: Text
-  , _input_date              :: Day
-  , _input_category          :: CategoryId
-  , _input_frequency         :: Frequency
-  , _input_mkPayload         :: Text -> Text -> Text -> CategoryId -> Frequency -> a
-  , _input_ajax              :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
+data In m t a = In
+  { _in_cancel            :: Event t ()
+  , _in_headerLabel       :: Text
+  , _in_categories        :: [Category]
+  , _in_paymentCategories :: [PaymentCategory]
+  , _in_name              :: Text
+  , _in_cost              :: Text
+  , _in_date              :: Day
+  , _in_category          :: CategoryId
+  , _in_frequency         :: Frequency
+  , _in_mkPayload         :: Text -> Text -> Text -> CategoryId -> Frequency -> a
+  , _in_ajax              :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
   }
 
-data Output t = Output
+data Out t = Out
   { _output_hide       :: Event t ()
   , _output_addPayment :: Event t SavedPayment
   }
 
-view :: forall t m a. (MonadWidget t m, ToJSON a) => Input m t a -> m (Output t)
+view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t)
 view input = do
   rec
     let reset = R.leftmost
-          [ "" <$ _modalFormOut_cancel modalForm
-          , "" <$ _modalFormOut_validate modalForm
-          , "" <$ _input_cancel input
+          [ "" <$ ModalForm._out_cancel modalForm
+          , "" <$ ModalForm._out_validate modalForm
+          , "" <$ _in_cancel input
           ]
 
-    modalForm <- Component.modalForm $ ModalFormIn
-      { _modalFormIn_headerLabel = _input_headerLabel input
-      , _modalFormIn_ajax        = _input_ajax input "/api/payment"
-      , _modalFormIn_form        = form reset (_modalFormOut_confirm modalForm)
+    modalForm <- ModalForm.view $ ModalForm.In
+      { ModalForm._in_headerLabel = _in_headerLabel input
+      , ModalForm._in_ajax        = _in_ajax input "/api/payment"
+      , ModalForm._in_form        = form reset (ModalForm._out_confirm modalForm)
       }
 
-  return $ Output
-    { _output_hide = _modalFormOut_hide modalForm
-    , _output_addPayment = _modalFormOut_validate modalForm
+  return $ Out
+    { _output_hide = ModalForm._out_hide modalForm
+    , _output_addPayment = ModalForm._out_validate modalForm
     }
 
   where
@@ -76,63 +75,63 @@ view input = do
       -> Event t ()
       -> m (Dynamic t (Validation (NonEmpty Text) a))
     form reset confirm = do
-      name <- Component.input
-        (Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Payment_Name
-          , _inputIn_initialValue = _input_name input
-          , _inputIn_validation = PaymentValidation.name
+      name <- Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Payment_Name
+          , Input._in_initialValue = _in_name input
+          , Input._in_validation = PaymentValidation.name
           })
-        (_input_name input <$ reset)
+        (_in_name input <$ reset)
         confirm
 
-      cost <- _inputOut_raw <$> (Component.input
-        (Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Payment_Cost
-          , _inputIn_initialValue = _input_cost input
-          , _inputIn_validation = PaymentValidation.cost
+      cost <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Payment_Cost
+          , Input._in_initialValue = _in_cost input
+          , Input._in_validation = PaymentValidation.cost
           })
-        (_input_cost input <$ reset)
+        (_in_cost input <$ reset)
         confirm)
 
-      let initialDate = T.pack . Calendar.showGregorian . _input_date $ input
+      let initialDate = T.pack . Calendar.showGregorian . _in_date $ input
 
-      date <- _inputOut_raw <$> (Component.input
-        (Component.defaultInputIn
-          { _inputIn_label = Msg.get Msg.Payment_Date
-          , _inputIn_initialValue = initialDate
-          , _inputIn_inputType = "date"
-          , _inputIn_hasResetButton = False
-          , _inputIn_validation = PaymentValidation.date
+      date <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Payment_Date
+          , Input._in_initialValue = initialDate
+          , Input._in_inputType = "date"
+          , Input._in_hasResetButton = False
+          , Input._in_validation = PaymentValidation.date
           })
         (initialDate <$ reset)
         confirm)
 
       let setCategory =
             R.fmapMaybe id . R.updated $
-              R.ffor (_inputOut_raw name) $ \name ->
-                findCategory name (_input_paymentCategories input)
-
-      category <- _selectOut_value <$> (Component.select $ SelectIn
-        { _selectIn_label = Msg.get Msg.Payment_Category
-        , _selectIn_initialValue = _input_category input
-        , _selectIn_value = setCategory
-        , _selectIn_values = R.constDyn categories
-        , _selectIn_reset = _input_category input <$ reset
-        , _selectIn_isValid = PaymentValidation.category (map _category_id $ _input_categories input)
-        , _selectIn_validate = confirm
+              R.ffor (Input._out_raw name) $ \name ->
+                findCategory name (_in_paymentCategories input)
+
+      category <- Select._out_value <$> (Select.view $ Select.In
+        { Select._in_label = Msg.get Msg.Payment_Category
+        , Select._in_initialValue = _in_category input
+        , Select._in_value = setCategory
+        , Select._in_values = R.constDyn categories
+        , Select._in_reset = _in_category input <$ reset
+        , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input)
+        , Select._in_validate = confirm
         })
 
       return $ do
-        n <- _inputOut_value name
+        n <- Input._out_value name
         c <- cost
         d <- date
         cat <- category
-        return ((_input_mkPayload input)
+        return ((_in_mkPayload input)
           <$> ValidationUtil.nelError n
           <*> V.Success c
           <*> V.Success d
           <*> ValidationUtil.nelError cat
-          <*> V.Success (_input_frequency input))
+          <*> V.Success (_in_frequency input))
 
     frequencies =
       M.fromList
@@ -140,7 +139,7 @@ view input = do
         , (Monthly, Msg.get Msg.Payment_MonthlyMale)
         ]
 
-    categories = M.fromList . flip map (_input_categories input) $ \c ->
+    categories = M.fromList . flip map (_in_categories input) $ \c ->
       (_category_id c, _category_name c)
 
 findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 9ad90a9..00987a3 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -1,7 +1,7 @@
 module View.Payment.Header
-  ( widget
-  , HeaderIn(..)
-  , HeaderOut(..)
+  ( view
+  , In(..)
+  , Out(..)
   ) where
 
 import           Control.Monad          (forM_)
@@ -27,31 +27,30 @@ import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
 
-import           Component              (ButtonIn (..), ButtonOut (..),
-                                         InputIn (..), InputOut (..),
-                                         SelectIn (..), SelectOut (..))
-import qualified Component              as Component
+import qualified Component.Button       as Button
+import qualified Component.Input        as Input
 import qualified Component.Modal        as Modal
+import qualified Component.Select       as Select
 import qualified Util.List              as L
 import qualified View.Payment.Add       as Add
 import           View.Payment.Init      (Init (..))
 
-data HeaderIn t = HeaderIn
-  { _headerIn_init              :: Init
-  , _headerIn_currency          :: Currency
-  , _headerIn_payments          :: Dynamic t [Payment]
-  , _headerIn_searchPayments    :: Dynamic t [Payment]
-  , _headerIn_paymentCategories :: Dynamic t [PaymentCategory]
+data In t = In
+  { _in_init              :: Init
+  , _in_currency          :: Currency
+  , _in_payments          :: Dynamic t [Payment]
+  , _in_searchPayments    :: Dynamic t [Payment]
+  , _in_paymentCategories :: Dynamic t [PaymentCategory]
   }
 
-data HeaderOut t = HeaderOut
-  { _headerOut_searchName      :: Dynamic t Text
-  , _headerOut_searchFrequency :: Dynamic t Frequency
-  , _headerOut_addPayment      :: Event t SavedPayment
+data Out t = Out
+  { _out_searchName      :: Dynamic t Text
+  , _out_searchFrequency :: Dynamic t Frequency
+  , _out_addPayment      :: Event t SavedPayment
   }
 
-widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
-widget headerIn =
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input =
   R.divClass "header" $ do
     rec
       addPayment <-
@@ -66,22 +65,22 @@ widget headerIn =
       let resetSearchName = fmap (const ()) $ addPayment
       (searchName, searchFrequency)  <- searchLine resetSearchName
 
-      infos (_headerIn_searchPayments headerIn) users currency
+      infos (_in_searchPayments input) users currency
 
-    return $ HeaderOut
-      { _headerOut_searchName = searchName
-      , _headerOut_searchFrequency = searchFrequency
-      , _headerOut_addPayment = addPayment
+    return $ Out
+      { _out_searchName = searchName
+      , _out_searchFrequency = searchFrequency
+      , _out_addPayment = addPayment
       }
   where
-    init = _headerIn_init headerIn
+    init = _in_init input
     incomes = _init_incomes init
     initPayments = _init_payments init
-    payments = _headerIn_payments headerIn
+    payments = _in_payments input
     users = _init_users init
     categories = _init_categories init
-    currency = _headerIn_currency headerIn
-    paymentCategories = _headerIn_paymentCategories headerIn
+    currency = _in_currency input
+    paymentCategories = _in_paymentCategories input
 
 payerAndAdd
   :: forall t m. MonadWidget t m
@@ -113,18 +112,18 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
             R.dynText . R.ffor exceedingPayer $ \ep ->
               Format.price currency $ _exceedingPayer_amount ep
 
-    addPayment <- _buttonOut_clic <$>
-      (Component.button $
-        (Component.defaultButtonIn (R.text $ Msg.get Msg.Payment_Add))
-          { _buttonIn_class = R.constDyn "addPayment"
+    addPayment <- Button._out_clic <$>
+      (Button.view $
+        (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
+          { Button._in_class = R.constDyn "addPayment"
           })
 
-    Modal.view $ Modal.Input
-      { Modal._input_show    = addPayment
-      , Modal._input_content = Add.view $ Add.Input
-          { Add._input_categories = categories
-          , Add._input_paymentCategories = paymentCategories
-          , Add._input_frequency = frequency
+    Modal.view $ Modal.In
+      { Modal._in_show    = addPayment
+      , Modal._in_content = Add.view $ Add.In
+          { Add._in_categories = categories
+          , Add._in_paymentCategories = paymentCategories
+          , Add._in_frequency = frequency
           }
       }
 
@@ -134,8 +133,8 @@ searchLine
   -> m (Dynamic t Text, Dynamic t Frequency)
 searchLine reset = do
   R.divClass "searchLine" $ do
-    searchName <- _inputOut_raw <$> (Component.input
-      ( Component.defaultInputIn { _inputIn_label = Msg.get Msg.Search_Name })
+    searchName <- Input._out_raw <$> (Input.view
+      ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
       ("" <$ reset)
       R.never)
 
@@ -144,15 +143,14 @@ searchLine reset = do
           , (Monthly, Msg.get Msg.Payment_MonthlyMale)
           ]
 
-    searchFrequency <- _selectOut_raw <$> (Component.select $
-      SelectIn
-        { _selectIn_label        = ""
-        , _selectIn_initialValue = Punctual
-        , _selectIn_value        = R.never
-        , _selectIn_values       = R.constDyn frequencies
-        , _selectIn_reset        = R.never
-        , _selectIn_isValid      = V.Success
-        , _selectIn_validate     = R.never
+    searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
+        { Select._in_label        = ""
+        , Select._in_initialValue = Punctual
+        , Select._in_value        = R.never
+        , Select._in_values       = R.constDyn frequencies
+        , Select._in_reset        = R.never
+        , Select._in_isValid      = V.Success
+        , Select._in_validate     = R.never
         })
 
     return (searchName, searchFrequency)
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
index 5681935..9a1902c 100644
--- a/client/src/View/Payment/Pages.hs
+++ b/client/src/View/Payment/Pages.hs
@@ -1,41 +1,40 @@
 module View.Payment.Pages
-  ( widget
-  , PagesIn(..)
-  , PagesOut(..)
+  ( view
+  , In(..)
+  , Out(..)
   ) where
 
-import qualified Data.Text   as T
-import           Reflex.Dom  (Dynamic, Event, 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           Component   (ButtonIn (..), ButtonOut (..))
-import qualified Component   as Component
+import qualified Component.Button as Button
 
-import qualified Util.Reflex as ReflexUtil
-import qualified View.Icon   as Icon
+import qualified Util.Reflex      as ReflexUtil
+import qualified View.Icon        as Icon
 
-data PagesIn t = PagesIn
-  { _pagesIn_total   :: Dynamic t Int
-  , _pagesIn_perPage :: Int
-  , _pagesIn_reset   :: Event t ()
+data In t = In
+  { _in_total   :: Dynamic t Int
+  , _in_perPage :: Int
+  , _in_reset   :: Event t ()
   }
 
-data PagesOut t = PagesOut
-  { _pagesOut_currentPage :: Dynamic t Int
+data Out t = Out
+  { _out_currentPage :: Dynamic t Int
   }
 
-widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
-widget pagesIn = do
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
   currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
 
-  return $ PagesOut
-    { _pagesOut_currentPage = currentPage
+  return $ Out
+    { _out_currentPage = currentPage
     }
 
   where
-    total = _pagesIn_total pagesIn
-    perPage = _pagesIn_perPage pagesIn
-    reset = _pagesIn_reset pagesIn
+    total = _in_total input
+    perPage = _in_perPage input
+    reset = _in_reset input
 
 pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
 pageButtons total perPage reset = do
@@ -75,14 +74,14 @@ range currentPage maxPage = [start..end]
 
 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 <$> (Component.button $ ButtonIn
-    { _buttonIn_class   = do
+  clic <- Button._out_clic <$> (Button.view $ Button.In
+    { Button._in_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
+    , Button._in_content = content
+    , Button._in_waiting = R.never
+    , Button._in_tabIndex = Nothing
+    , Button._in_submit = False
     })
   return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index 5f0d03c..f86acd8 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -1,7 +1,7 @@
 module View.Payment.Payment
   ( init
   , view
-  , PaymentIn(..)
+  , In(..)
   ) where
 
 import           Data.Text           (Text)
@@ -20,12 +20,9 @@ import qualified Common.Util.Text    as T
 import           Loadable            (Loadable (..))
 import qualified Loadable
 import qualified Util.Ajax           as AjaxUtil
-import           View.Payment.Header (HeaderIn (..), HeaderOut (..))
 import qualified View.Payment.Header as Header
 import           View.Payment.Init   (Init (..))
-import           View.Payment.Pages  (PagesIn (..), PagesOut (..))
 import qualified View.Payment.Pages  as Pages
-import           View.Payment.Table  (TableIn (..), TableOut (..))
 import qualified View.Payment.Table  as Table
 
 init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
@@ -44,21 +41,21 @@ init = do
     return $ Init <$> us <*> ps <*> is <*> cs <*> pcs
 
 
-data PaymentIn t = PaymentIn
-  { _paymentIn_currentUser :: UserId
-  , _paymentIn_currency    :: Currency
-  , _paymentIn_init        :: Dynamic t (Loadable Init)
+data In t = In
+  { _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  , _in_init        :: Dynamic t (Loadable Init)
   }
 
-view :: forall t m. MonadWidget t m => PaymentIn t -> m ()
-view paymentIn = do
-  R.dyn . R.ffor (_paymentIn_init paymentIn) . Loadable.view $ \init ->
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input = do
+  R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
 
     R.elClass "main" "payment" $ do
       rec
         let addPayment = R.leftmost
-              [ _headerOut_addPayment header
-              , _tableOut_addPayment table
+              [ Header._out_addPayment header
+              , Table._out_addPayment table
               ]
 
             paymentsPerPage = 7
@@ -66,46 +63,46 @@ view paymentIn = do
         payments <- reducePayments
           (_init_payments init)
           (_savedPayment_payment <$> addPayment)
-          (_savedPayment_payment <$> _tableOut_editPayment table)
-          (_tableOut_deletePayment table)
+          (_savedPayment_payment <$> Table._out_editPayment table)
+          (Table._out_deletePayment table)
 
         paymentCategories <- reducePaymentCategories
           (_init_paymentCategories init)
           payments
           (_savedPayment_paymentCategory <$> addPayment)
-          (_savedPayment_paymentCategory <$> _tableOut_editPayment table)
-          (_tableOut_deletePayment table)
+          (_savedPayment_paymentCategory <$> Table._out_editPayment table)
+          (Table._out_deletePayment table)
 
         (searchNameEvent, searchName) <-
-          debounceSearchName (_headerOut_searchName header)
+          debounceSearchName (Header._out_searchName header)
 
         let searchPayments =
-              getSearchPayments searchName (_headerOut_searchFrequency header) payments
-
-        header <- Header.widget $ HeaderIn
-          { _headerIn_init = init
-          , _headerIn_currency = _paymentIn_currency paymentIn
-          , _headerIn_payments = payments
-          , _headerIn_searchPayments = searchPayments
-          , _headerIn_paymentCategories = paymentCategories
+              getSearchPayments searchName (Header._out_searchFrequency header) payments
+
+        header <- Header.view $ Header.In
+          { Header._in_init = init
+          , Header._in_currency = _in_currency input
+          , Header._in_payments = payments
+          , Header._in_searchPayments = searchPayments
+          , Header._in_paymentCategories = paymentCategories
           }
 
-        table <- Table.widget $ TableIn
-          { _tableIn_init = init
-          , _tableIn_currency = _paymentIn_currency paymentIn
-          , _tableIn_currentUser = _paymentIn_currentUser paymentIn
-          , _tableIn_currentPage = _pagesOut_currentPage pages
-          , _tableIn_payments = searchPayments
-          , _tableIn_perPage = paymentsPerPage
-          , _tableIn_paymentCategories = paymentCategories
+        table <- Table.view $ Table.In
+          { Table._in_init = init
+          , Table._in_currency = _in_currency input
+          , Table._in_currentUser = _in_currentUser input
+          , Table._in_currentPage = Pages._out_currentPage pages
+          , Table._in_payments = searchPayments
+          , Table._in_perPage = paymentsPerPage
+          , Table._in_paymentCategories = paymentCategories
           }
 
-        pages <- Pages.widget $ PagesIn
-          { _pagesIn_total = length <$> searchPayments
-          , _pagesIn_perPage = paymentsPerPage
-          , _pagesIn_reset = R.leftmost $
+        pages <- Pages.view $ Pages.In
+          { Pages._in_total = length <$> searchPayments
+          , Pages._in_perPage = paymentsPerPage
+          , Pages._in_reset = R.leftmost $
               [ () <$ searchNameEvent
-              , () <$ _headerOut_addPayment header
+              , () <$ Header._out_addPayment header
               ]
           }
 
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 3a0a4bf..0793836 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -1,7 +1,7 @@
 module View.Payment.Table
-  ( widget
-  , TableIn(..)
-  , TableOut(..)
+  ( view
+  , In(..)
+  , Out(..)
   ) where
 
 import qualified Data.List           as L
@@ -20,8 +20,7 @@ import           Common.Model        (Category (..), Currency,
 import qualified Common.Model        as CM
 import qualified Common.Msg          as Msg
 import qualified Common.View.Format  as Format
-import           Component           (ButtonIn (..), ButtonOut (..))
-import qualified Component           as Component
+import qualified Component.Button    as Button
 import qualified Component.Modal     as Modal
 import qualified View.Payment.Clone  as Clone
 import qualified View.Payment.Delete as Delete
@@ -31,25 +30,25 @@ import           View.Payment.Init   (Init (..))
 import qualified Util.Reflex         as ReflexUtil
 import qualified View.Icon           as Icon
 
-data TableIn t = TableIn
-  { _tableIn_init              :: Init
-  , _tableIn_currency          :: Currency
-  , _tableIn_currentUser       :: UserId
-  , _tableIn_currentPage       :: Dynamic t Int
-  , _tableIn_payments          :: Dynamic t [Payment]
-  , _tableIn_perPage           :: Int
-  , _tableIn_paymentCategories :: Dynamic t [PaymentCategory]
-  , _tableIn_categories        :: [Category]
+data In t = In
+  { _in_init              :: Init
+  , _in_currency          :: Currency
+  , _in_currentUser       :: UserId
+  , _in_currentPage       :: Dynamic t Int
+  , _in_payments          :: Dynamic t [Payment]
+  , _in_perPage           :: Int
+  , _in_paymentCategories :: Dynamic t [PaymentCategory]
+  , _in_categories        :: [Category]
   }
 
-data TableOut t = TableOut
-  { _tableOut_addPayment    :: Event t SavedPayment
-  , _tableOut_editPayment   :: Event t SavedPayment
-  , _tableOut_deletePayment :: Event t Payment
+data Out t = Out
+  { _out_addPayment    :: Event t SavedPayment
+  , _out_editPayment   :: Event t SavedPayment
+  , _out_deletePayment :: Event t Payment
   }
 
-widget :: forall t m. MonadWidget t m => TableIn t -> m (TableOut t)
-widget tableIn = do
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
   R.divClass "table" $ do
 
     (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do
@@ -75,20 +74,20 @@ widget tableIn = do
     ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
       R.text $ Msg.get Msg.Payment_Empty
 
-    return $ TableOut
-      { _tableOut_addPayment = addPayment
-      , _tableOut_editPayment = editPayment
-      , _tableOut_deletePayment = deletePayment
+    return $ Out
+      { _out_addPayment = addPayment
+      , _out_editPayment = editPayment
+      , _out_deletePayment = deletePayment
       }
 
   where
-    init = _tableIn_init tableIn
-    currency = _tableIn_currency tableIn
-    currentUser = _tableIn_currentUser tableIn
-    currentPage = _tableIn_currentPage tableIn
-    payments = _tableIn_payments tableIn
-    paymentRange = getPaymentRange (_tableIn_perPage tableIn) <$> payments <*> currentPage
-    paymentCategories = _tableIn_paymentCategories tableIn
+    init = _in_init input
+    currency = _in_currency input
+    currentUser = _in_currentUser input
+    currentPage = _in_currentPage input
+    payments = _in_payments input
+    paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage
+    paymentCategories = _in_paymentCategories input
 
 getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
 getPaymentRange perPage payments currentPage =
@@ -150,19 +149,19 @@ paymentRow init currency currentUser paymentCategories payment =
 
     clonePayment <-
       R.divClass "cell button" $
-        _buttonOut_clic <$> (Component.button $
-          Component.defaultButtonIn Icon.clone)
+        Button._out_clic <$> (Button.view $
+          Button.defaultIn Icon.clone)
 
     paymentCloned <-
-      Modal.view $ Modal.Input
-        { Modal._input_show    = clonePayment
-        , Modal._input_content =
-            Clone.view $ Clone.Input
-              { Clone._input_show = clonePayment
-              , Clone._input_categories = _init_categories init
-              , Clone._input_paymentCategories = paymentCategories
-              , Clone._input_payment = payment
-              , Clone._input_category = categoryId
+      Modal.view $ Modal.In
+        { Modal._in_show    = clonePayment
+        , Modal._in_content =
+            Clone.view $ Clone.In
+              { Clone._in_show = clonePayment
+              , Clone._in_categories = _init_categories init
+              , Clone._in_paymentCategories = paymentCategories
+              , Clone._in_payment = payment
+              , Clone._in_category = categoryId
               }
         }
 
@@ -174,36 +173,36 @@ paymentRow init currency currentUser paymentCategories payment =
     editPayment <-
       R.divClass "cell button" $
         ReflexUtil.divVisibleIf isFromCurrentUser $
-          _buttonOut_clic <$> (Component.button $
-            Component.defaultButtonIn Icon.edit)
+          Button._out_clic <$> (Button.view $
+            Button.defaultIn Icon.edit)
 
     paymentEdited <-
-      Modal.view $ Modal.Input
-        { Modal._input_show    = editPayment
-        , Modal._input_content =
-            Edit.view $ Edit.Input
-              { Edit._input_show = editPayment
-              , Edit._input_categories = _init_categories init
-              , Edit._input_paymentCategories = paymentCategories
-              , Edit._input_payment = payment
-              , Edit._input_category = categoryId
+      Modal.view $ Modal.In
+        { Modal._in_show    = editPayment
+        , Modal._in_content =
+            Edit.view $ Edit.In
+              { Edit._in_show = editPayment
+              , Edit._in_categories = _init_categories init
+              , Edit._in_paymentCategories = paymentCategories
+              , Edit._in_payment = payment
+              , Edit._in_category = categoryId
               }
         }
 
     deletePayment <-
       R.divClass "cell button" $
         ReflexUtil.divVisibleIf isFromCurrentUser $
-          _buttonOut_clic <$> (Component.button $
-            (Component.defaultButtonIn Icon.delete)
-              { _buttonIn_class = R.constDyn "deletePayment"
+          Button._out_clic <$> (Button.view $
+            (Button.defaultIn Icon.delete)
+              { Button._in_class = R.constDyn "deletePayment"
               })
 
     paymentDeleted <-
-      Modal.view $ Modal.Input
-        { Modal._input_show    = deletePayment
-        , Modal._input_content =
-            Delete.view $ Delete.Input
-              { Delete._input_payment = payment
+      Modal.view $ Modal.In
+        { Modal._in_show    = deletePayment
+        , Modal._in_content =
+            Delete.view $ Delete.In
+              { Delete._in_payment = payment
               }
         }
 
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 4fe495b..a589fc3 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -15,9 +15,9 @@ import           Common.Model             (SignInForm (SignInForm))
 import qualified Common.Msg               as Msg
 import qualified Common.Validation.SignIn as SignInValidation
 
-import           Component                (ButtonIn (..), ButtonOut (..),
-                                           InputIn (..), InputOut (..))
-import qualified Component                as Component
+import qualified Component.Button         as Button
+import qualified Component.Form           as Form
+import qualified Component.Input          as Input
 import qualified Util.Ajax                as Ajax
 import qualified Util.Validation          as ValidationUtil
 import qualified Util.WaitFor             as WaitFor
@@ -30,24 +30,24 @@ data SignInMessage =
 view :: forall t m. MonadWidget t m => SignInMessage -> m ()
 view signInMessage =
   R.divClass "signIn" $
-    Component.form $ do
+    Form.view $ do
       rec
-        input <- (Component.input
-          (Component.defaultInputIn
-            { _inputIn_label = Msg.get Msg.SignIn_EmailLabel
-            , _inputIn_validation = SignInValidation.email
+        input <- (Input.view
+          (Input.defaultIn
+            { Input._in_label = Msg.get Msg.SignIn_EmailLabel
+            , Input._in_validation = SignInValidation.email
             })
           ("" <$ R.ffilter Either.isRight signInResult)
           validate)
 
-        validate <- _buttonOut_clic <$> (Component.button $
-          (Component.defaultButtonIn (R.text $ Msg.get Msg.SignIn_Button))
-            { _buttonIn_class = R.constDyn "validate"
-            , _buttonIn_waiting = waiting
-            , _buttonIn_submit = True
+        validate <- Button._out_clic <$> (Button.view $
+          (Button.defaultIn (R.text $ Msg.get Msg.SignIn_Button))
+            { Button._in_class = R.constDyn "validate"
+            , Button._in_waiting = waiting
+            , Button._in_submit = True
             })
 
-        let form = SignInForm <$> _inputOut_raw input
+        let form = SignInForm <$> Input._out_raw input
 
         (signInResult, waiting) <- WaitFor.waitFor
           (Ajax.post "/api/askSignIn")
-- 
cgit v1.2.3


From 61ff1443c42def5a09f624e3df2e2520e97610d0 Mon Sep 17 00:00:00 2001
From: Joris
Date: Tue, 22 Oct 2019 23:25:05 +0200
Subject: Clone incomes

---
 client/src/Component/Table.hs    | 54 +++++++++++++++++++++++++++++-----------
 client/src/View/Income/Add.hs    | 20 ++++++++++-----
 client/src/View/Income/Header.hs |  2 +-
 client/src/View/Income/Income.hs | 17 +++++++------
 client/src/View/Income/Table.hs  | 32 ++++++++++++++++--------
 client/src/View/Payment/Clone.hs |  6 ++---
 6 files changed, 90 insertions(+), 41 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index bf76566..5819f45 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -4,56 +4,82 @@ module Component.Table
   , Out(..)
   ) where
 
-import           Data.Text       (Text)
-import           Reflex.Dom      (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom      as R
+import           Data.Text        (Text)
+import           Reflex.Dom       (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom       as R
 
-import qualified Component.Pages as Pages
+import qualified Component.Button as Button
+import qualified Component.Modal  as Modal
+import qualified Component.Pages  as Pages
+import qualified Util.Reflex      as ReflexUtil
+import qualified View.Icon        as Icon
 
-data In h r t = In
+data In m t h r a = In
   { _in_headerLabel :: h -> Text
   , _in_rows        :: Dynamic t [r]
   , _in_cell        :: h -> r -> Text
   , _in_perPage     :: Int
   , _in_resetPage   :: Event t ()
+  , _in_cloneModal  :: Dynamic t r -> Modal.Content t m a
   }
 
-data Out = Out
-  {}
+data Out t a = Out
+  { _out_add :: Event t a
+  }
 
-view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h)  => In h r t -> m (Out)
+view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h)  => In m t h r a -> m (Out t a)
 view input =
   R.divClass "table" $ do
     rec
-      R.divClass "lines" $ do
+      result <- R.divClass "lines" $ do
 
-        R.divClass "header" $
+        R.divClass "header" $ do
           flip mapM_ [minBound..] $ \header ->
             R.divClass "cell" . R.text $
               _in_headerLabel input header
 
+          R.divClass "cell" $ R.blank
+
         let rows = getRange
               (_in_perPage input)
                 <$> (Pages._out_currentPage pages)
                 <*> (_in_rows input)
 
         R.simpleList rows $ \r ->
-          R.divClass "row" $
+          R.divClass "row" $ do
             flip mapM_ [minBound..] $ \h ->
-              R.divClass "cell name" $
+              R.divClass "cell" $
                 R.dynText $
                   R.ffor r (_in_cell input h)
 
+            clone <-
+              R.divClass "cell button" $
+                Button._out_clic <$> (Button.view $
+                  Button.defaultIn Icon.clone)
+
+            cloned <-
+              Modal.view $ Modal.In
+                { Modal._in_show    = clone
+                , Modal._in_content = _in_cloneModal input r
+                }
+
+            return cloned
+
       pages <- Pages.view $ Pages.In
         { Pages._in_total = length <$> (_in_rows input)
         , Pages._in_perPage = _in_perPage input
         , Pages._in_reset = _in_resetPage input
         }
 
-      return ()
+      -- return $
+      --   ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
+      --   , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
+      --   , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
+      --   )
 
     return $ Out
-      {}
+      { _out_add = R.switch . R.current . fmap R.leftmost $ result
+      }
 
 getRange :: forall a. Int -> Int -> [a] -> [a]
 getRange perPage currentPage =
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
index f8f107f..d07bd45 100644
--- a/client/src/View/Income/Add.hs
+++ b/client/src/View/Income/Add.hs
@@ -1,13 +1,16 @@
 module View.Income.Add
   ( view
+  , In(..)
   ) where
 
 import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Maybe             as Maybe
+import qualified Data.Text              as T
 import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (MonadWidget)
+import           Reflex.Dom             (Dynamic, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (CreateIncomeForm (..), Income)
+import           Common.Model           (CreateIncomeForm (..), Income (..))
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as TimeUtil
 import qualified Component.Modal        as Modal
@@ -15,16 +18,21 @@ import qualified Util.Ajax              as Ajax
 import qualified Util.Reflex            as ReflexUtil
 import qualified View.Income.Form       as Form
 
-view :: forall t m. MonadWidget t m => Modal.Content t m Income
-view cancel = do
+data In t = In
+  { _in_income :: Dynamic t (Maybe Income)
+  }
+
+view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income
+view input cancel = do
 
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
-  form <- R.dyn $
+  form <- R.dyn $ do
+    income <- _in_income input
     return $ Form.view $ Form.In
       { Form._in_cancel = cancel
       , Form._in_headerLabel = Msg.get Msg.Income_AddLong
-      , Form._in_amount = ""
+      , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income)
       , Form._in_date = currentDay
       , Form._in_mkPayload = CreateIncomeForm
       , Form._in_ajax = Ajax.post
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index ae1174a..0360d1f 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -72,7 +72,7 @@ view input =
 
       addIncome <- Modal.view $ Modal.In
         { Modal._in_show    = addIncome
-        , Modal._in_content = Add.view
+        , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing }
         }
 
       return $ Out
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index f8359bb..b97613d 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -41,11 +41,14 @@ view input = do
     R.elClass "main" "income" $ do
 
       rec
-
+        let addIncome = R.leftmost
+              [ Header._out_addIncome header
+              , Table._out_addIncome table
+              ]
         incomes <- R.foldDyn
           (:)
           (_init_incomes init)
-          (Header._out_addIncome header)
+          addIncome
 
         header <- Header.view $ Header.In
           { Header._in_init = init
@@ -53,11 +56,11 @@ view input = do
           , Header._in_incomes = incomes
           }
 
-      Table.view $ Table.In
-        { Table._in_init = init
-        , Table._in_currency = _in_currency input
-        , Table._in_incomes = incomes
-        }
+        table <- Table.view $ Table.In
+          { Table._in_init = init
+          , Table._in_currency = _in_currency input
+          , Table._in_incomes = incomes
+          }
 
       return ()
 
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 9cb705f..358cb17 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -1,12 +1,13 @@
 module View.Income.Table
   ( view
   , In(..)
+  , Out(..)
   ) where
 
 import qualified Data.List          as L
 import qualified Data.Maybe         as Maybe
 import           Data.Text          (Text)
-import           Reflex.Dom         (Dynamic, MonadWidget)
+import           Reflex.Dom         (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom         as R
 
 import           Common.Model       (Currency, Income (..), User (..))
@@ -15,6 +16,7 @@ import qualified Common.Msg         as Msg
 import qualified Common.View.Format as Format
 
 import qualified Component.Table    as Table
+import qualified View.Income.Add    as Add
 import           View.Income.Init   (Init (..))
 
 data In t = In
@@ -23,18 +25,28 @@ data In t = In
   , _in_incomes  :: Dynamic t [Income]
   }
 
-view :: forall t m. MonadWidget t m => In t -> m ()
+data Out t = Out
+  { _out_addIncome :: Event t Income
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
 view input = do
 
-    Table.view $ Table.In
-      { Table._in_headerLabel = headerLabel
-      , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
-      , Table._in_cell = cell (_in_init input) (_in_currency input)
-      , Table._in_perPage = 7
-      , Table._in_resetPage = R.never
-      }
+  table <- Table.view $ Table.In
+    { Table._in_headerLabel = headerLabel
+    , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
+    , Table._in_cell = cell (_in_init input) (_in_currency input)
+    , Table._in_perPage = 7
+    , Table._in_resetPage = R.never
+    , Table._in_cloneModal = \income ->
+      Add.view $ Add.In
+        { Add._in_income = Just <$> income
+        }
+    }
 
-    return ()
+  return $ Out
+    { _out_addIncome = Table._out_add table
+    }
 
 data Header
   = UserHeader
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
index 56a33d9..82b0c27 100644
--- a/client/src/View/Payment/Clone.hs
+++ b/client/src/View/Payment/Clone.hs
@@ -34,7 +34,7 @@ view input cancel = do
 
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
-  formOutput <- R.dyn $ do
+  form <- R.dyn $ do
     paymentCategories <- _in_paymentCategories input
     payment <- _in_payment input
     category <- _in_category input
@@ -52,8 +52,8 @@ view input cancel = do
       , Form._in_ajax = Ajax.post
       }
 
-  hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
-  clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
+  hide <- ReflexUtil.flatten (Form._output_hide <$> form)
+  clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form)
 
   return $
     ( hide
-- 
cgit v1.2.3


From f968c8ce63e1aec119b1e6f414cf27e2c0294bcb Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 21:09:54 +0200
Subject: Delete income

---
 client/src/Component/ConfirmDialog.hs | 49 +++++++++++++++++++++++++++++++
 client/src/Component/Table.hs         | 42 ++++++++++++++++++++-------
 client/src/Util/Reflex.hs             |  8 ++++++
 client/src/View/App.hs                |  3 +-
 client/src/View/Income/Add.hs         | 22 +++++++-------
 client/src/View/Income/Header.hs      |  6 ++--
 client/src/View/Income/Income.hs      | 33 +++++++++++++++------
 client/src/View/Income/Table.hs       | 54 +++++++++++++++++++++++------------
 client/src/View/Payment/Delete.hs     |  1 -
 9 files changed, 163 insertions(+), 55 deletions(-)
 create mode 100644 client/src/Component/ConfirmDialog.hs

(limited to 'client/src')

diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs
new file mode 100644
index 0000000..50e30ed
--- /dev/null
+++ b/client/src/Component/ConfirmDialog.hs
@@ -0,0 +1,49 @@
+module Component.ConfirmDialog
+  ( In(..)
+  , view
+  ) where
+
+import           Data.Text        (Text)
+import           Reflex.Dom       (Event, MonadWidget)
+import qualified Reflex.Dom       as R
+
+import qualified Common.Msg       as Msg
+import qualified Component.Button as Button
+import qualified Component.Modal  as Modal
+import qualified Util.Either      as EitherUtil
+import qualified Util.WaitFor     as WaitFor
+
+data In t m a = In
+  { _in_header  :: Text
+  , _in_confirm :: Event t () -> m (Event t a)
+  }
+
+view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a
+view input _ =
+  R.divClass "confirm" $ do
+    R.divClass "confirmHeader" $
+      R.text $ _in_header input
+
+    R.divClass "confirmContent" $ do
+      (confirm, cancel) <- R.divClass "buttons" $ do
+
+        cancel <- Button._out_clic <$> (Button.view $
+          (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+            { Button._in_class = R.constDyn "undo" })
+
+        rec
+          confirm <- Button._out_clic <$> (Button.view $
+            (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
+              { Button._in_class = R.constDyn "confirm"
+              , Button._in_submit = True
+              , Button._in_waiting = waiting
+              })
+
+          (result, waiting) <- WaitFor.waitFor (_in_confirm input) confirm
+
+        return (result, cancel)
+
+      return $
+        ( R.leftmost [ cancel, () <$ confirm ]
+        , confirm
+        )
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 5819f45..b3c70a0 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -20,11 +20,14 @@ data In m t h r a = In
   , _in_cell        :: h -> r -> Text
   , _in_perPage     :: Int
   , _in_resetPage   :: Event t ()
-  , _in_cloneModal  :: Dynamic t r -> Modal.Content t m a
+  , _in_cloneModal  :: r -> Modal.Content t m a
+  , _in_deleteModal :: r -> Modal.Content t m a
+  , _in_isOwner     :: r -> Bool
   }
 
 data Out t a = Out
-  { _out_add :: Event t a
+  { _out_add    :: Event t a
+  , _out_delete :: Event t a
   }
 
 view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h)  => In m t h r a -> m (Out t a)
@@ -39,6 +42,7 @@ view input =
               _in_headerLabel input header
 
           R.divClass "cell" $ R.blank
+          R.divClass "cell" $ R.blank
 
         let rows = getRange
               (_in_perPage input)
@@ -60,25 +64,41 @@ view input =
             cloned <-
               Modal.view $ Modal.In
                 { Modal._in_show    = clone
-                , Modal._in_content = _in_cloneModal input r
+                , Modal._in_content = \curtainClick ->
+                  (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick)
+                    >>= ReflexUtil.flattenTuple
+                }
+
+            let isOwner = R.ffor r (_in_isOwner input)
+
+            delete <-
+              R.divClass "cell button" $
+                ReflexUtil.divVisibleIf isOwner $
+                  Button._out_clic <$> (Button.view $
+                    Button.defaultIn Icon.delete)
+
+            deleted <-
+              Modal.view $ Modal.In
+                { Modal._in_show    = delete
+                , Modal._in_content = \curtainClick ->
+                  (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick)
+                    >>= ReflexUtil.flattenTuple
                 }
 
-            return cloned
+            return (cloned, deleted)
 
       pages <- Pages.view $ Pages.In
-        { Pages._in_total = length <$> (_in_rows input)
+        { Pages._in_total = length <$> _in_rows input
         , Pages._in_perPage = _in_perPage input
         , Pages._in_reset = _in_resetPage input
         }
 
-      -- return $
-      --   ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
-      --   , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
-      --   , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
-      --   )
+    let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result
+        delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result
 
     return $ Out
-      { _out_add = R.switch . R.current . fmap R.leftmost $ result
+      { _out_add = add
+      , _out_delete = delete
       }
 
 getRange :: forall a. Int -> Int -> [a] -> [a]
diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
index c14feeb..9f51c5c 100644
--- a/client/src/Util/Reflex.hs
+++ b/client/src/Util/Reflex.hs
@@ -4,6 +4,7 @@ module Util.Reflex
   , divVisibleIf
   , divClassVisibleIf
   , flatten
+  , flattenTuple
   , getBody
   ) where
 
@@ -44,6 +45,13 @@ flatten e = do
   dyn <- R.holdDyn R.never e
   return $ R.switchDyn dyn
 
+
+flattenTuple
+  :: forall t m a b. MonadWidget t m
+  => Event t (Event t a, Event t b)
+  -> m (Event t a, Event t b)
+flattenTuple e = (,) <$> (flatten $ fmap fst e) <*> (flatten $ fmap snd e)
+
 getBody :: forall t m. MonadWidget t m => m Element
 getBody = do
   document <- Dom.currentDocumentUnchecked
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index e0a52e2..1e26417 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -69,7 +69,8 @@ signedWidget init route = do
     IncomeRoute -> do
       incomeInit <- Income.init
       Income.view $ Income.In
-        { Income._in_currency = _init_currency init
+        { Income._in_currentUser = _init_currentUser init
+        , Income._in_currency = _init_currency init
         , Income._in_init = incomeInit
         }
 
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
index d07bd45..7780d73 100644
--- a/client/src/View/Income/Add.hs
+++ b/client/src/View/Income/Add.hs
@@ -7,19 +7,18 @@ import           Control.Monad.IO.Class (liftIO)
 import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
 import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Dynamic, MonadWidget)
-import qualified Reflex.Dom             as R
+import           Reflex.Dom             (MonadWidget)
 
 import           Common.Model           (CreateIncomeForm (..), Income (..))
 import qualified Common.Msg             as Msg
 import qualified Common.Util.Time       as TimeUtil
+import qualified Component.Form
 import qualified Component.Modal        as Modal
 import qualified Util.Ajax              as Ajax
-import qualified Util.Reflex            as ReflexUtil
 import qualified View.Income.Form       as Form
 
 data In t = In
-  { _in_income :: Dynamic t (Maybe Income)
+  { _in_income :: Maybe Income
   }
 
 view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income
@@ -27,18 +26,17 @@ view input cancel = do
 
   currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
 
-  form <- R.dyn $ do
-    income <- _in_income input
-    return $ Form.view $ Form.In
+  let amount =
+        Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input))
+
+  form <-
+    Component.Form.view $ Form.view $ Form.In
       { Form._in_cancel = cancel
       , Form._in_headerLabel = Msg.get Msg.Income_AddLong
-      , Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income)
+      , Form._in_amount = amount
       , Form._in_date = currentDay
       , Form._in_mkPayload = CreateIncomeForm
       , Form._in_ajax = Ajax.post
       }
 
-  hide <- ReflexUtil.flatten (Form._out_hide <$> form)
-  addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form)
-
-  return (hide, addIncome)
+  return (Form._out_hide form, Form._out_addIncome form)
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 0360d1f..f17e774 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -29,7 +29,7 @@ data In t = In
   }
 
 data Out t = Out
-  { _out_addIncome :: Event t Income
+  { _out_add :: Event t Income
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
@@ -72,11 +72,11 @@ view input =
 
       addIncome <- Modal.view $ Modal.In
         { Modal._in_show    = addIncome
-        , Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing }
+        , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing }
         }
 
       return $ Out
-        { _out_addIncome = addIncome
+        { _out_add = addIncome
         }
 
   where
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index b97613d..2784cac 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -6,10 +6,10 @@ module View.Income.Income
 
 import           Data.Aeson         (FromJSON)
 import           Prelude            hiding (init)
-import           Reflex.Dom         (Dynamic, MonadWidget)
+import           Reflex.Dom         (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom         as R
 
-import           Common.Model       (Currency)
+import           Common.Model       (Currency, Income (..), UserId)
 
 import           Loadable           (Loadable (..))
 import qualified Loadable
@@ -19,8 +19,9 @@ import           View.Income.Init   (Init (..))
 import qualified View.Income.Table  as Table
 
 data In t = In
-  { _in_currency :: Currency
-  , _in_init     :: Dynamic t (Loadable Init)
+  { _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  , _in_init        :: Dynamic t (Loadable Init)
   }
 
 init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
@@ -42,13 +43,14 @@ view input = do
 
       rec
         let addIncome = R.leftmost
-              [ Header._out_addIncome header
-              , Table._out_addIncome table
+              [ Header._out_add header
+              , Table._out_add table
               ]
-        incomes <- R.foldDyn
-          (:)
+
+        incomes <- reduceIncomes
           (_init_incomes init)
           addIncome
+          (Table._out_delete table)
 
         header <- Header.view $ Header.In
           { Header._in_init = init
@@ -57,7 +59,8 @@ view input = do
           }
 
         table <- Table.view $ Table.In
-          { Table._in_init = init
+          { Table._in_currentUser = _in_currentUser input
+          , Table._in_init = init
           , Table._in_currency = _in_currency input
           , Table._in_incomes = incomes
           }
@@ -65,3 +68,15 @@ view input = do
       return ()
 
   return ()
+
+reduceIncomes
+  :: forall t m. MonadWidget t m
+  => [Income]
+  -> Event t Income -- add income
+  -> Event t Income -- delete income
+  -> m (Dynamic t [Income])
+reduceIncomes initIncomes add delete =
+  R.foldDyn id initIncomes $ R.leftmost
+    [ (:) <$> add
+    , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id))
+    ]
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 358cb17..16ebf7c 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -4,29 +4,36 @@ module View.Income.Table
   , Out(..)
   ) where
 
-import qualified Data.List          as L
-import qualified Data.Maybe         as Maybe
-import           Data.Text          (Text)
-import           Reflex.Dom         (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom         as R
+import qualified Data.List               as L
+import qualified Data.Maybe              as Maybe
+import           Data.Text               (Text)
+import qualified Data.Text               as T
+import           Reflex.Dom              (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom              as R
 
-import           Common.Model       (Currency, Income (..), User (..))
-import qualified Common.Model       as CM
-import qualified Common.Msg         as Msg
-import qualified Common.View.Format as Format
+import           Common.Model            (Currency, Income (..), User (..),
+                                          UserId)
+import qualified Common.Model            as CM
+import qualified Common.Msg              as Msg
+import qualified Common.View.Format      as Format
 
-import qualified Component.Table    as Table
-import qualified View.Income.Add    as Add
-import           View.Income.Init   (Init (..))
+import qualified Component.ConfirmDialog as ConfirmDialog
+import qualified Component.Table         as Table
+import qualified Util.Ajax               as Ajax
+import qualified Util.Either             as EitherUtil
+import qualified View.Income.Add         as Add
+import           View.Income.Init        (Init (..))
 
 data In t = In
-  { _in_init     :: Init
-  , _in_currency :: Currency
-  , _in_incomes  :: Dynamic t [Income]
+  { _in_currentUser :: UserId
+  , _in_init        :: Init
+  , _in_currency    :: Currency
+  , _in_incomes     :: Dynamic t [Income]
   }
 
 data Out t = Out
-  { _out_addIncome :: Event t Income
+  { _out_add    :: Event t Income
+  , _out_delete :: Event t Income
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
@@ -40,12 +47,23 @@ view input = do
     , Table._in_resetPage = R.never
     , Table._in_cloneModal = \income ->
       Add.view $ Add.In
-        { Add._in_income = Just <$> income
+        { Add._in_income = Just income
         }
+    , Table._in_deleteModal = \income ->
+      ConfirmDialog.view $ ConfirmDialog.In
+        { ConfirmDialog._in_header  = Msg.get Msg.Income_DeleteConfirm
+        , ConfirmDialog._in_confirm = \e -> do
+          res <- Ajax.delete
+            (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income])
+            e
+          return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+        }
+    , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId
     }
 
   return $ Out
-    { _out_addIncome = Table._out_add table
+    { _out_add = Table._out_add table
+    , _out_delete = Table._out_delete table
     }
 
 data Header
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
index 471463c..e5e7219 100644
--- a/client/src/View/Payment/Delete.hs
+++ b/client/src/View/Payment/Delete.hs
@@ -12,7 +12,6 @@ import           Common.Model     (Payment (..))
 import qualified Common.Msg       as Msg
 import qualified Component.Button as Button
 import qualified Component.Modal  as Modal
-import qualified Component.Modal  as Modal
 import qualified Util.Ajax        as Ajax
 import qualified Util.Either      as EitherUtil
 import qualified Util.WaitFor     as WaitFor
-- 
cgit v1.2.3


From e4b32ce15f8c92f3b477d3f3d4d301ba08f9b5e3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 22:35:27 +0200
Subject: Edit an income

---
 client/src/Component/ModalForm.hs | 50 +++++++++++-----------
 client/src/Component/Table.hs     | 25 +++++++++--
 client/src/View/Income/Add.hs     | 42 ------------------
 client/src/View/Income/Form.hs    | 89 +++++++++++++++++++++++++++------------
 client/src/View/Income/Header.hs  |  7 +--
 client/src/View/Income/Income.hs  |  9 ++--
 client/src/View/Income/Table.hs   | 17 +++++---
 7 files changed, 131 insertions(+), 108 deletions(-)
 delete mode 100644 client/src/View/Income/Add.hs

(limited to 'client/src')

diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
index ea53beb..f5bf287 100644
--- a/client/src/Component/ModalForm.hs
+++ b/client/src/Component/ModalForm.hs
@@ -15,6 +15,7 @@ import qualified Reflex.Dom         as R
 
 import qualified Common.Msg         as Msg
 import qualified Component.Button   as Button
+import qualified Component.Form     as Form
 import qualified Util.Either        as EitherUtil
 import qualified Util.Validation    as ValidationUtil
 import qualified Util.WaitFor       as WaitFor
@@ -38,32 +39,33 @@ view input =
     R.divClass "formHeader" $
       R.text (_in_headerLabel input)
 
-    R.divClass "formContent" $ do
-      rec
-        form <- _in_form input
+    Form.view $
+      R.divClass "formContent" $ do
+        rec
+          form <- _in_form input
 
-        (validate, cancel, confirm) <- R.divClass "buttons" $ do
-          rec
-            cancel <- Button._out_clic <$> (Button.view $
-              (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
-                { Button._in_class = R.constDyn "undo" })
+          (validate, cancel, confirm) <- R.divClass "buttons" $ do
+            rec
+              cancel <- Button._out_clic <$> (Button.view $
+                (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+                  { Button._in_class = R.constDyn "undo" })
 
-            confirm <- Button._out_clic <$> (Button.view $
-              (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
-                { Button._in_class = R.constDyn "confirm"
-                , Button._in_waiting = waiting
-                , Button._in_submit = True
-                })
+              confirm <- Button._out_clic <$> (Button.view $
+                (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
+                  { Button._in_class = R.constDyn "confirm"
+                  , Button._in_waiting = waiting
+                  , Button._in_submit = True
+                  })
 
-            (validate, waiting) <- WaitFor.waitFor
-              (_in_ajax input)
-              (ValidationUtil.fireValidation form confirm)
+              (validate, waiting) <- WaitFor.waitFor
+                (_in_ajax input)
+                (ValidationUtil.fireValidation form confirm)
 
-          return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
+            return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
 
-      return Out
-        { _out_hide = R.leftmost [ cancel, () <$ validate ]
-        , _out_cancel = cancel
-        , _out_confirm = confirm
-        , _out_validate = validate
-        }
+        return Out
+          { _out_hide = R.leftmost [ cancel, () <$ validate ]
+          , _out_cancel = cancel
+          , _out_confirm = confirm
+          , _out_validate = validate
+          }
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index b3c70a0..a02eaa7 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -21,12 +21,14 @@ data In m t h r a = In
   , _in_perPage     :: Int
   , _in_resetPage   :: Event t ()
   , _in_cloneModal  :: r -> Modal.Content t m a
+  , _in_editModal   :: r -> Modal.Content t m a
   , _in_deleteModal :: r -> Modal.Content t m a
   , _in_isOwner     :: r -> Bool
   }
 
 data Out t a = Out
   { _out_add    :: Event t a
+  , _out_edit   :: Event t a
   , _out_delete :: Event t a
   }
 
@@ -43,6 +45,7 @@ view input =
 
           R.divClass "cell" $ R.blank
           R.divClass "cell" $ R.blank
+          R.divClass "cell" $ R.blank
 
         let rows = getRange
               (_in_perPage input)
@@ -71,6 +74,20 @@ view input =
 
             let isOwner = R.ffor r (_in_isOwner input)
 
+            edit <-
+              R.divClass "cell button" $
+                ReflexUtil.divVisibleIf isOwner $
+                  Button._out_clic <$> (Button.view $
+                    Button.defaultIn Icon.edit)
+
+            edited <-
+              Modal.view $ Modal.In
+                { Modal._in_show    = edit
+                , Modal._in_content = \curtainClick ->
+                  (R.dyn . R.ffor r $ \r2 -> _in_editModal input r2 curtainClick)
+                    >>= ReflexUtil.flattenTuple
+                }
+
             delete <-
               R.divClass "cell button" $
                 ReflexUtil.divVisibleIf isOwner $
@@ -85,7 +102,7 @@ view input =
                     >>= ReflexUtil.flattenTuple
                 }
 
-            return (cloned, deleted)
+            return (cloned, edited, deleted)
 
       pages <- Pages.view $ Pages.In
         { Pages._in_total = length <$> _in_rows input
@@ -93,11 +110,13 @@ view input =
         , Pages._in_reset = _in_resetPage input
         }
 
-    let add = R.switch . R.current . fmap (R.leftmost . map fst) $ result
-        delete = R.switch . R.current . fmap (R.leftmost . map snd) $ result
+    let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
+        edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result
+        delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result
 
     return $ Out
       { _out_add = add
+      , _out_edit = edit
       , _out_delete = delete
       }
 
diff --git a/client/src/View/Income/Add.hs b/client/src/View/Income/Add.hs
deleted file mode 100644
index 7780d73..0000000
--- a/client/src/View/Income/Add.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-module View.Income.Add
-  ( view
-  , In(..)
-  ) where
-
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.Maybe             as Maybe
-import qualified Data.Text              as T
-import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (MonadWidget)
-
-import           Common.Model           (CreateIncomeForm (..), Income (..))
-import qualified Common.Msg             as Msg
-import qualified Common.Util.Time       as TimeUtil
-import qualified Component.Form
-import qualified Component.Modal        as Modal
-import qualified Util.Ajax              as Ajax
-import qualified View.Income.Form       as Form
-
-data In t = In
-  { _in_income :: Maybe Income
-  }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income
-view input cancel = do
-
-  currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
-
-  let amount =
-        Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> (_in_income input))
-
-  form <-
-    Component.Form.view $ Form.view $ Form.In
-      { Form._in_cancel = cancel
-      , Form._in_headerLabel = Msg.get Msg.Income_AddLong
-      , Form._in_amount = amount
-      , Form._in_date = currentDay
-      , Form._in_mkPayload = CreateIncomeForm
-      , Form._in_ajax = Ajax.post
-      }
-
-  return (Form._out_hide form, Form._out_addIncome form)
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index 917edf1..5f354a2 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -1,60 +1,59 @@
 module View.Income.Form
   ( view
   , In(..)
-  , Out(..)
+  , Operation(..)
   ) where
 
-import           Data.Aeson               (FromJSON, ToJSON)
+import           Control.Monad.IO.Class   (liftIO)
+import           Data.Aeson               (ToJSON)
+import qualified Data.Maybe               as Maybe
 import           Data.Text                (Text)
 import qualified Data.Text                as T
-import           Data.Time.Calendar       (Day)
 import qualified Data.Time.Calendar       as Calendar
+import qualified Data.Time.Clock          as Time
 import           Data.Validation          (Validation)
 import qualified Data.Validation          as V
 import           Reflex.Dom               (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom               as R
 
-import           Common.Model             (Income)
+import           Common.Model             (EditIncomeForm (..), Income (..))
 import qualified Common.Msg               as Msg
+import qualified Common.Util.Time         as TimeUtil
 import qualified Common.Validation.Income as IncomeValidation
 import qualified Component.Input          as Input
+import qualified Component.Modal          as Modal
 import qualified Component.ModalForm      as ModalForm
+import qualified Util.Ajax                as Ajax
 
-data In m t a = In
-  { _in_cancel      :: Event t ()
-  , _in_headerLabel :: Text
-  , _in_amount      :: Text
-  , _in_date        :: Day
-  , _in_mkPayload   :: Text -> Text -> a
-  , _in_ajax        :: Text -> Event t a -> m (Event t (Either Text Income))
+data In t a = In
+  { _in_operation :: Operation a
   }
 
-data Out t = Out
-  { _out_hide      :: Event t ()
-  , _out_addIncome :: Event t Income
-  }
+data Operation a
+  = New (Text -> Text -> a)
+  | Clone (Text -> Text -> a) Income
+  | Edit (Text -> Text -> a) Income
+
+view :: forall t m a. (MonadWidget t m, ToJSON a) => In t a -> Modal.Content t m Income
+view input cancel = do
 
-view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t)
-view input = do
   rec
     let reset = R.leftmost
           [ "" <$ ModalForm._out_cancel modalForm
           , "" <$ ModalForm._out_validate modalForm
-          , "" <$ _in_cancel input
+          , "" <$ cancel
           ]
 
     modalForm <- ModalForm.view $ ModalForm.In
-      { ModalForm._in_headerLabel = _in_headerLabel input
-      , ModalForm._in_ajax        = _in_ajax input "/api/income"
+      { ModalForm._in_headerLabel = headerLabel
+      , ModalForm._in_ajax        = ajax "/api/income"
       , ModalForm._in_form        = form reset (ModalForm._out_confirm modalForm)
       }
 
-  return $ Out
-    { _out_hide = ModalForm._out_hide modalForm
-    , _out_addIncome = ModalForm._out_validate modalForm
-    }
+  return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm)
 
   where
+
     form
       :: Event t String
       -> Event t ()
@@ -63,13 +62,15 @@ view input = do
       amount <- Input._out_raw <$> (Input.view
         (Input.defaultIn
           { Input._in_label = Msg.get Msg.Income_Amount
-          , Input._in_initialValue = _in_amount input
+          , Input._in_initialValue = amount
           , Input._in_validation = IncomeValidation.amount
           })
-        (_in_amount input <$ reset)
+        (amount <$ reset)
         confirm)
 
-      let initialDate = T.pack . Calendar.showGregorian . _in_date $ input
+      currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
+
+      let initialDate = T.pack . Calendar.showGregorian $ date currentDay
 
       date <- Input._out_raw <$> (Input.view
         (Input.defaultIn
@@ -85,4 +86,36 @@ view input = do
       return $ do
         a <- amount
         d <- date
-        return . V.Success $ (_in_mkPayload input) a d
+        return . V.Success $ mkPayload a d
+
+    op = _in_operation input
+
+    amount =
+      case op of
+        New _          -> ""
+        Clone _ income -> T.pack . show . _income_amount $ income
+        Edit _ income  -> T.pack . show . _income_amount $ income
+
+    date currentDay =
+      case op of
+        New _         -> currentDay
+        Clone _ _     -> currentDay
+        Edit _ income -> _income_date income
+
+    ajax =
+      case op of
+        New _     -> Ajax.post
+        Clone _ _ -> Ajax.post
+        Edit _ _  -> Ajax.put
+
+    headerLabel =
+      case op of
+        New _     -> Msg.get Msg.Income_AddLong
+        Clone _ _ -> Msg.get Msg.Income_AddLong
+        Edit _ _  -> Msg.get Msg.Income_Edit
+
+    mkPayload =
+      case op of
+        New f     -> f
+        Clone f _ -> f
+        Edit f _  -> f
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index f17e774..182db33 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -11,7 +11,8 @@ import qualified Data.Time.Clock        as Clock
 import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, Income (..), User (..))
+import           Common.Model           (CreateIncomeForm (..), Currency,
+                                         Income (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -19,7 +20,7 @@ import qualified Common.View.Format     as Format
 import qualified Component.Button       as Button
 import qualified Component.Modal        as Modal
 import qualified Util.Date              as DateUtil
-import qualified View.Income.Add        as Add
+import qualified View.Income.Form       as Form
 import           View.Income.Init       (Init (..))
 
 data In t = In
@@ -72,7 +73,7 @@ view input =
 
       addIncome <- Modal.view $ Modal.In
         { Modal._in_show    = addIncome
-        , Modal._in_content = Add.view $ Add.In { Add._in_income = Nothing }
+        , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New CreateIncomeForm }
         }
 
       return $ Out
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 2784cac..90f1fde 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -50,6 +50,7 @@ view input = do
         incomes <- reduceIncomes
           (_init_incomes init)
           addIncome
+          (Table._out_edit table)
           (Table._out_delete table)
 
         header <- Header.view $ Header.In
@@ -72,11 +73,13 @@ view input = do
 reduceIncomes
   :: forall t m. MonadWidget t m
   => [Income]
-  -> Event t Income -- add income
-  -> Event t Income -- delete income
+  -> Event t Income -- add
+  -> Event t Income -- edit
+  -> Event t Income -- delete
   -> m (Dynamic t [Income])
-reduceIncomes initIncomes add delete =
+reduceIncomes initIncomes add edit delete =
   R.foldDyn id initIncomes $ R.leftmost
     [ (:) <$> add
+    , R.ffor edit (\p -> (p:) . filter ((/= (_income_id p)) . _income_id))
     , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id))
     ]
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 16ebf7c..f865fd9 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -11,8 +11,9 @@ import qualified Data.Text               as T
 import           Reflex.Dom              (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom              as R
 
-import           Common.Model            (Currency, Income (..), User (..),
-                                          UserId)
+import           Common.Model            (CreateIncomeForm (..), Currency,
+                                          EditIncomeForm (..), Income (..),
+                                          User (..), UserId)
 import qualified Common.Model            as CM
 import qualified Common.Msg              as Msg
 import qualified Common.View.Format      as Format
@@ -21,7 +22,7 @@ import qualified Component.ConfirmDialog as ConfirmDialog
 import qualified Component.Table         as Table
 import qualified Util.Ajax               as Ajax
 import qualified Util.Either             as EitherUtil
-import qualified View.Income.Add         as Add
+import qualified View.Income.Form        as Form
 import           View.Income.Init        (Init (..))
 
 data In t = In
@@ -33,6 +34,7 @@ data In t = In
 
 data Out t = Out
   { _out_add    :: Event t Income
+  , _out_edit   :: Event t Income
   , _out_delete :: Event t Income
   }
 
@@ -46,8 +48,12 @@ view input = do
     , Table._in_perPage = 7
     , Table._in_resetPage = R.never
     , Table._in_cloneModal = \income ->
-      Add.view $ Add.In
-        { Add._in_income = Just income
+      Form.view $ Form.In
+        { Form._in_operation = Form.Clone CreateIncomeForm income
+        }
+    , Table._in_editModal = \income ->
+      Form.view $ Form.In
+        { Form._in_operation = Form.Edit (EditIncomeForm $ _income_id income) income
         }
     , Table._in_deleteModal = \income ->
       ConfirmDialog.view $ ConfirmDialog.In
@@ -63,6 +69,7 @@ view input = do
 
   return $ Out
     { _out_add = Table._out_add table
+    , _out_edit = Table._out_edit table
     , _out_delete = Table._out_delete table
     }
 
-- 
cgit v1.2.3


From c53198a7dd46f1575a33f823c29fa02126429e8f Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 23 Oct 2019 22:41:51 +0200
Subject: Go to initial page after adding an income

---
 client/src/View/Income/Income.hs | 1 +
 client/src/View/Income/Table.hs  | 3 ++-
 2 files changed, 3 insertions(+), 1 deletion(-)

(limited to 'client/src')

diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 90f1fde..2f0b8f5 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -64,6 +64,7 @@ view input = do
           , Table._in_init = init
           , Table._in_currency = _in_currency input
           , Table._in_incomes = incomes
+          , Table._in_resetPage = () <$ addIncome
           }
 
       return ()
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index f865fd9..c754a77 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -30,6 +30,7 @@ data In t = In
   , _in_init        :: Init
   , _in_currency    :: Currency
   , _in_incomes     :: Dynamic t [Income]
+  , _in_resetPage   :: Event t ()
   }
 
 data Out t = Out
@@ -46,7 +47,7 @@ view input = do
     , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
     , Table._in_cell = cell (_in_init input) (_in_currency input)
     , Table._in_perPage = 7
-    , Table._in_resetPage = R.never
+    , Table._in_resetPage = _in_resetPage input
     , Table._in_cloneModal = \income ->
       Form.view $ Form.In
         { Form._in_operation = Form.Clone CreateIncomeForm income
-- 
cgit v1.2.3


From 8ef4d96644bce59bbb736af6359e644743e5610a Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 27 Oct 2019 17:02:43 +0100
Subject: Refactor income form component concerning payload creation

---
 client/src/View/Income/Form.hs   | 48 +++++++++++++++++++---------------------
 client/src/View/Income/Header.hs |  5 ++---
 client/src/View/Income/Table.hs  |  9 ++++----
 3 files changed, 29 insertions(+), 33 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index 5f354a2..a4f7de8 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -5,7 +5,8 @@ module View.Income.Form
   ) where
 
 import           Control.Monad.IO.Class   (liftIO)
-import           Data.Aeson               (ToJSON)
+import           Data.Aeson               (Value)
+import qualified Data.Aeson               as Aeson
 import qualified Data.Maybe               as Maybe
 import           Data.Text                (Text)
 import qualified Data.Text                as T
@@ -16,7 +17,8 @@ import qualified Data.Validation          as V
 import           Reflex.Dom               (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom               as R
 
-import           Common.Model             (EditIncomeForm (..), Income (..))
+import           Common.Model             (CreateIncomeForm (..),
+                                           EditIncomeForm (..), Income (..))
 import qualified Common.Msg               as Msg
 import qualified Common.Util.Time         as TimeUtil
 import qualified Common.Validation.Income as IncomeValidation
@@ -25,16 +27,16 @@ import qualified Component.Modal          as Modal
 import qualified Component.ModalForm      as ModalForm
 import qualified Util.Ajax                as Ajax
 
-data In t a = In
-  { _in_operation :: Operation a
+data In t = In
+  { _in_operation :: Operation
   }
 
-data Operation a
-  = New (Text -> Text -> a)
-  | Clone (Text -> Text -> a) Income
-  | Edit (Text -> Text -> a) Income
+data Operation
+  = New
+  | Clone Income
+  | Edit Income
 
-view :: forall t m a. (MonadWidget t m, ToJSON a) => In t a -> Modal.Content t m Income
+view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income
 view input cancel = do
 
   rec
@@ -57,7 +59,7 @@ view input cancel = do
     form
       :: Event t String
       -> Event t ()
-      -> m (Dynamic t (Validation Text a))
+      -> m (Dynamic t (Validation Text Value))
     form reset confirm = do
       amount <- Input._out_raw <$> (Input.view
         (Input.defaultIn
@@ -92,30 +94,26 @@ view input cancel = do
 
     amount =
       case op of
-        New _          -> ""
-        Clone _ income -> T.pack . show . _income_amount $ income
-        Edit _ income  -> T.pack . show . _income_amount $ income
+        New          -> ""
+        Clone income -> T.pack . show . _income_amount $ income
+        Edit income  -> T.pack . show . _income_amount $ income
 
     date currentDay =
       case op of
-        New _         -> currentDay
-        Clone _ _     -> currentDay
-        Edit _ income -> _income_date income
+        Edit income -> _income_date income
+        _           -> currentDay
 
     ajax =
       case op of
-        New _     -> Ajax.post
-        Clone _ _ -> Ajax.post
-        Edit _ _  -> Ajax.put
+        Edit _ -> Ajax.put
+        _      -> Ajax.post
 
     headerLabel =
       case op of
-        New _     -> Msg.get Msg.Income_AddLong
-        Clone _ _ -> Msg.get Msg.Income_AddLong
-        Edit _ _  -> Msg.get Msg.Income_Edit
+        Edit _ -> Msg.get Msg.Income_Edit
+        _      -> Msg.get Msg.Income_AddLong
 
     mkPayload =
       case op of
-        New f     -> f
-        Clone f _ -> f
-        Edit f _  -> f
+        Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b
+        _         -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 182db33..8e82525 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -11,8 +11,7 @@ import qualified Data.Time.Clock        as Clock
 import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (CreateIncomeForm (..), Currency,
-                                         Income (..), User (..))
+import           Common.Model           (Currency, Income (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -73,7 +72,7 @@ view input =
 
       addIncome <- Modal.view $ Modal.In
         { Modal._in_show    = addIncome
-        , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New CreateIncomeForm }
+        , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
         }
 
       return $ Out
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index c754a77..d089d9f 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -11,9 +11,8 @@ import qualified Data.Text               as T
 import           Reflex.Dom              (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom              as R
 
-import           Common.Model            (CreateIncomeForm (..), Currency,
-                                          EditIncomeForm (..), Income (..),
-                                          User (..), UserId)
+import           Common.Model            (Currency, Income (..), User (..),
+                                          UserId)
 import qualified Common.Model            as CM
 import qualified Common.Msg              as Msg
 import qualified Common.View.Format      as Format
@@ -50,11 +49,11 @@ view input = do
     , Table._in_resetPage = _in_resetPage input
     , Table._in_cloneModal = \income ->
       Form.view $ Form.In
-        { Form._in_operation = Form.Clone CreateIncomeForm income
+        { Form._in_operation = Form.Clone income
         }
     , Table._in_editModal = \income ->
       Form.view $ Form.In
-        { Form._in_operation = Form.Edit (EditIncomeForm $ _income_id income) income
+        { Form._in_operation = Form.Edit income
         }
     , Table._in_deleteModal = \income ->
       ConfirmDialog.view $ ConfirmDialog.In
-- 
cgit v1.2.3


From b97ad942495352c3fc1e0c820cfba82a9693ac7a Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 27 Oct 2019 20:26:29 +0100
Subject: WIP Set up server side paging for incomes

---
 client/src/Component/Pages.hs     |  37 ++++++++------
 client/src/Component/Table.hs     |  20 +-------
 client/src/Loadable.hs            |   9 ++++
 client/src/View/Income/Income.hs  | 101 +++++++++++++++++++-------------------
 client/src/View/Income/Reducer.hs |  66 +++++++++++++++++++++++++
 client/src/View/Income/Table.hs   |  13 ++---
 6 files changed, 151 insertions(+), 95 deletions(-)
 create mode 100644 client/src/View/Income/Reducer.hs

(limited to 'client/src')

diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
index 7284a36..a297222 100644
--- a/client/src/Component/Pages.hs
+++ b/client/src/Component/Pages.hs
@@ -16,38 +16,43 @@ import qualified View.Icon        as Icon
 data In t = In
   { _in_total   :: Dynamic t Int
   , _in_perPage :: Int
-  , _in_reset   :: Event t ()
   }
 
 data Out t = Out
-  { _out_currentPage :: Dynamic t Int
+  { _out_newPage     :: Event t Int
+  , _out_currentPage :: Dynamic t Int
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
 view input = do
-  currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
+  (newPage, currentPage) <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage
 
   return $ Out
-    { _out_currentPage = currentPage
+    { _out_newPage = newPage
+    , _out_currentPage = currentPage
     }
 
   where
     total = _in_total input
     perPage = _in_perPage input
-    reset = _in_reset input
 
-pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
-pageButtons total perPage reset = do
+pageButtons
+  :: forall t m. MonadWidget t m
+  => Dynamic t Int
+  -> Int
+  -> m (Event t Int, Dynamic t Int)
+pageButtons total perPage = do
   R.divClass "pages" $ do
     rec
-      currentPage <- R.holdDyn 1 . R.leftmost $
-        [ firstPageClic
-        , previousPageClic
-        , pageClic
-        , nextPageClic
-        , lastPageClic
-        , 1 <$ reset
-        ]
+      let newPage = R.leftmost
+            [ firstPageClic
+            , previousPageClic
+            , pageClic
+            , nextPageClic
+            , lastPageClic
+            ]
+
+      currentPage <- R.holdDyn 1 newPage
 
       firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
 
@@ -60,7 +65,7 @@ pageButtons total perPage reset = do
 
       lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
 
-    return currentPage
+    return (newPage, currentPage)
 
     where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
           pageEvent = R.switch . R.current . fmap R.leftmost
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index a02eaa7..7103abd 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -10,7 +10,6 @@ import qualified Reflex.Dom       as R
 
 import qualified Component.Button as Button
 import qualified Component.Modal  as Modal
-import qualified Component.Pages  as Pages
 import qualified Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
@@ -18,8 +17,6 @@ data In m t h r a = In
   { _in_headerLabel :: h -> Text
   , _in_rows        :: Dynamic t [r]
   , _in_cell        :: h -> r -> Text
-  , _in_perPage     :: Int
-  , _in_resetPage   :: Event t ()
   , _in_cloneModal  :: r -> Modal.Content t m a
   , _in_editModal   :: r -> Modal.Content t m a
   , _in_deleteModal :: r -> Modal.Content t m a
@@ -47,12 +44,7 @@ view input =
           R.divClass "cell" $ R.blank
           R.divClass "cell" $ R.blank
 
-        let rows = getRange
-              (_in_perPage input)
-                <$> (Pages._out_currentPage pages)
-                <*> (_in_rows input)
-
-        R.simpleList rows $ \r ->
+        R.simpleList (_in_rows input) $ \r ->
           R.divClass "row" $ do
             flip mapM_ [minBound..] $ \h ->
               R.divClass "cell" $
@@ -104,12 +96,6 @@ view input =
 
             return (cloned, edited, deleted)
 
-      pages <- Pages.view $ Pages.In
-        { Pages._in_total = length <$> _in_rows input
-        , Pages._in_perPage = _in_perPage input
-        , Pages._in_reset = _in_resetPage input
-        }
-
     let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
         edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result
         delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result
@@ -119,7 +105,3 @@ view input =
       , _out_edit = edit
       , _out_delete = delete
       }
-
-getRange :: forall a. Int -> Int -> [a] -> [a]
-getRange perPage currentPage =
-  take perPage . drop ((currentPage - 1) * perPage)
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index 8714a4d..a5c1d41 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -49,3 +49,12 @@ view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m ()
 view _ (Loading)  = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
 view _ (Error e)  = R.text e
 view f (Loaded x) = f x
+
+-- view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
+-- view _ (Loading)  = do
+--   R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
+--   return Nothing
+-- view _ (Error e)  = do
+--   R.text e
+--   return Nothing
+-- view f (Loaded x) = Just <$> (f x)
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index 2f0b8f5..c48f325 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -4,19 +4,23 @@ module View.Income.Income
   , In(..)
   ) where
 
-import           Data.Aeson         (FromJSON)
-import           Prelude            hiding (init)
-import           Reflex.Dom         (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom         as R
+import           Data.Aeson          (FromJSON)
+import           Prelude             hiding (init)
+import           Reflex.Dom          (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom          as R
 
-import           Common.Model       (Currency, Income (..), UserId)
+import           Common.Model        (Currency, Income (..),
+                                      IncomesAndCount (..), UserId)
 
-import           Loadable           (Loadable (..))
+import qualified Component.Pages     as Pages
+import           Loadable            (Loadable (..))
 import qualified Loadable
-import qualified Util.Ajax          as AjaxUtil
-import qualified View.Income.Header as Header
-import           View.Income.Init   (Init (..))
-import qualified View.Income.Table  as Table
+import qualified Util.Ajax           as AjaxUtil
+import qualified Util.Reflex         as ReflexUtil
+-- import qualified View.Income.Header as Header
+import           View.Income.Init    (Init (..))
+import qualified View.Income.Reducer as Reducer
+import qualified View.Income.Table   as Table
 
 data In t = In
   { _in_currentUser :: UserId
@@ -37,50 +41,45 @@ init = do
 
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
-  R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
+  -- rec
+    -- incomes <- Reducer.reducer
+    --   { Reducer._in_newPage      = ReflexUtil.flatten (Table._out_newPage <$> table)
+    --   , Reducer._in_currentPage  = ReflexUtil.flatten (Table._out_currentPage <$> table)
+    --   , Reducer._in_addIncome    = ReflexUtil.flatten (Table._out_add <$> table)
+    --   , Reducer._in_editIncome   = ReflexUtil.flatten (Table._out_edit <$> table)
+    --   , Reducer._in_deleteIncome = ReflexUtil.flatten (Table._out_delete <$> table)
+    --   }
 
-    R.elClass "main" "income" $ do
+  rec
+    incomes <- Reducer.reducer $ Reducer.In
+      { Reducer._in_newPage      = Pages._out_newPage pages
+      , Reducer._in_currentPage  = Pages._out_currentPage pages
+      , Reducer._in_addIncome    = Table._out_add table
+      , Reducer._in_editIncome   = Table._out_edit table
+      , Reducer._in_deleteIncome = Table._out_delete table
+      }
 
-      rec
-        let addIncome = R.leftmost
-              [ Header._out_add header
-              , Table._out_add table
-              ]
+    table <- Table.view $ Table.In
+      { Table._in_currentUser = _in_currentUser input
+      , Table._in_currency = _in_currency input
+      , Table._in_incomes = R.ffor incomes $ \case
+          Loaded (IncomesAndCount xs _) -> xs
+          _         -> []
+      }
 
-        incomes <- reduceIncomes
-          (_init_incomes init)
-          addIncome
-          (Table._out_edit table)
-          (Table._out_delete table)
+    pages <- Pages.view $ Pages.In
+      { Pages._in_total = R.ffor incomes $ \case
+          Loaded (IncomesAndCount _ n) -> n
+          _         -> 0
+      , Pages._in_perPage = Reducer.perPage
+      }
 
-        header <- Header.view $ Header.In
-          { Header._in_init = init
-          , Header._in_currency = _in_currency input
-          , Header._in_incomes = incomes
-          }
-
-        table <- Table.view $ Table.In
-          { Table._in_currentUser = _in_currentUser input
-          , Table._in_init = init
-          , Table._in_currency = _in_currency input
-          , Table._in_incomes = incomes
-          , Table._in_resetPage = () <$ addIncome
-          }
-
-      return ()
+  -- -- table :: Event t (Maybe (Table.Out t))
+  -- table <- R.dyn . R.ffor incomes . Loadable.view $ \incomes ->
+  --   Table.view $ Table.In
+  --     { Table._in_currentUser = _in_currentUser input
+  --     , Table._in_currency = _in_currency input
+  --     , Table._in_incomes = incomes
+  --     }
 
   return ()
-
-reduceIncomes
-  :: forall t m. MonadWidget t m
-  => [Income]
-  -> Event t Income -- add
-  -> Event t Income -- edit
-  -> Event t Income -- delete
-  -> m (Dynamic t [Income])
-reduceIncomes initIncomes add edit delete =
-  R.foldDyn id initIncomes $ R.leftmost
-    [ (:) <$> add
-    , R.ffor edit (\p -> (p:) . filter ((/= (_income_id p)) . _income_id))
-    , R.ffor delete (\p -> filter ((/= (_income_id p)) . _income_id))
-    ]
diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs
new file mode 100644
index 0000000..5b346cb
--- /dev/null
+++ b/client/src/View/Income/Reducer.hs
@@ -0,0 +1,66 @@
+module View.Income.Reducer
+  ( perPage
+  , reducer
+  , In(..)
+  ) where
+
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (IncomesAndCount)
+
+import           Loadable     (Loadable (..))
+import qualified Loadable     as Loadable
+import qualified Util.Ajax    as AjaxUtil
+
+perPage :: Int
+perPage = 7
+
+data In t a b c = In
+  { _in_newPage      :: Event t Int
+  , _in_currentPage  :: Dynamic t Int
+  , _in_addIncome    :: Event t a
+  , _in_editIncome   :: Event t b
+  , _in_deleteIncome :: Event t c
+  }
+
+data Action
+  = LoadPage Int
+  | GetResult (Either Text IncomesAndCount)
+
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomesAndCount))
+reducer input = do
+
+  postBuild <- R.getPostBuild
+
+  let loadPage =
+        R.leftmost
+          [ 1 <$ postBuild
+          , _in_newPage input
+          , 1 <$ _in_addIncome input
+          , R.tag (R.current $ _in_currentPage input) (_in_editIncome input)
+          , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input)
+          ]
+
+  getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+
+  R.foldDyn
+    (\action _ -> case action of
+      LoadPage _                -> Loading
+      GetResult (Left err)      -> Error err
+      GetResult (Right incomes) -> Loaded incomes
+    )
+    Loading
+    (R.leftmost
+      [ LoadPage <$> loadPage
+      , GetResult <$> getResult
+      ])
+
+  where
+    pageUrl p =
+      "api/v2/incomes?page="
+      <> (T.pack . show $ p)
+      <> "&perPage="
+      <> (T.pack . show $ perPage)
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index d089d9f..6d69c19 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -22,14 +22,11 @@ import qualified Component.Table         as Table
 import qualified Util.Ajax               as Ajax
 import qualified Util.Either             as EitherUtil
 import qualified View.Income.Form        as Form
-import           View.Income.Init        (Init (..))
 
 data In t = In
   { _in_currentUser :: UserId
-  , _in_init        :: Init
   , _in_currency    :: Currency
   , _in_incomes     :: Dynamic t [Income]
-  , _in_resetPage   :: Event t ()
   }
 
 data Out t = Out
@@ -44,9 +41,7 @@ view input = do
   table <- Table.view $ Table.In
     { Table._in_headerLabel = headerLabel
     , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
-    , Table._in_cell = cell (_in_init input) (_in_currency input)
-    , Table._in_perPage = 7
-    , Table._in_resetPage = _in_resetPage input
+    , Table._in_cell = cell [] (_in_currency input)
     , Table._in_cloneModal = \income ->
       Form.view $ Form.In
         { Form._in_operation = Form.Clone income
@@ -84,11 +79,11 @@ headerLabel UserHeader   = Msg.get Msg.Income_Name
 headerLabel DateHeader   = Msg.get Msg.Income_Date
 headerLabel AmountHeader = Msg.get Msg.Income_Amount
 
-cell :: Init -> Currency -> Header -> Income -> Text
-cell init currency header income =
+cell :: [User] -> Currency -> Header -> Income -> Text
+cell users currency header income =
   case header of
     UserHeader ->
-      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) (_init_users init)
+      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
 
     DateHeader ->
       Format.longDay . _income_date $ income
-- 
cgit v1.2.3


From 227dcd4435b775d7dbc5ae5d3d81b589897253cc Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 2 Nov 2019 20:52:27 +0100
Subject: Implement incomes server side paging

---
 client/src/Component/Pages.hs    | 22 +++++---------
 client/src/Component/Table.hs    | 62 +++++++++++++++++++-------------------
 client/src/Loadable.hs           | 17 +++--------
 client/src/Util/Reflex.hs        |  1 -
 client/src/View/Income/Income.hs | 65 +++++++++++++++++++---------------------
 client/src/View/Income/Table.hs  |  4 +--
 6 files changed, 76 insertions(+), 95 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
index a297222..d54cd3d 100644
--- a/client/src/Component/Pages.hs
+++ b/client/src/Component/Pages.hs
@@ -16,32 +16,26 @@ import qualified View.Icon        as Icon
 data In t = In
   { _in_total   :: Dynamic t Int
   , _in_perPage :: Int
+  , _in_page    :: Int
   }
 
 data Out t = Out
   { _out_newPage     :: Event t Int
-  , _out_currentPage :: Dynamic t Int
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
 view input = do
-  (newPage, currentPage) <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage
+  newPage <- ReflexUtil.divVisibleIf ((> 0) <$> (_in_total input)) $ pageButtons input
 
   return $ Out
     { _out_newPage = newPage
-    , _out_currentPage = currentPage
     }
 
-  where
-    total = _in_total input
-    perPage = _in_perPage input
-
 pageButtons
   :: forall t m. MonadWidget t m
-  => Dynamic t Int
-  -> Int
-  -> m (Event t Int, Dynamic t Int)
-pageButtons total perPage = do
+  => In t
+  -> m (Event t Int)
+pageButtons input = do
   R.divClass "pages" $ do
     rec
       let newPage = R.leftmost
@@ -52,7 +46,7 @@ pageButtons total perPage = do
             , lastPageClic
             ]
 
-      currentPage <- R.holdDyn 1 newPage
+      currentPage <- R.holdDyn (_in_page input) newPage
 
       firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
 
@@ -65,9 +59,9 @@ pageButtons total perPage = do
 
       lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
 
-    return (newPage, currentPage)
+    return newPage
 
-    where maxPage = R.ffor total (\t -> ceiling $ toRational t / toRational perPage)
+    where maxPage = R.ffor (_in_total input) (\t -> ceiling $ toRational t / toRational (_in_perPage input))
           pageEvent = R.switch . R.current . fmap R.leftmost
           noCurrentPage = R.constDyn Nothing
 
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 7103abd..3b9ec24 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -4,8 +4,9 @@ module Component.Table
   , Out(..)
   ) where
 
+import qualified Data.Map as M
 import           Data.Text        (Text)
-import           Reflex.Dom       (Dynamic, Event, MonadWidget)
+import           Reflex.Dom       (Event, MonadWidget)
 import qualified Reflex.Dom       as R
 
 import qualified Component.Button as Button
@@ -15,7 +16,7 @@ import qualified View.Icon        as Icon
 
 data In m t h r a = In
   { _in_headerLabel :: h -> Text
-  , _in_rows        :: Dynamic t [r]
+  , _in_rows        :: [r]
   , _in_cell        :: h -> r -> Text
   , _in_cloneModal  :: r -> Modal.Content t m a
   , _in_editModal   :: r -> Modal.Content t m a
@@ -44,61 +45,60 @@ view input =
           R.divClass "cell" $ R.blank
           R.divClass "cell" $ R.blank
 
-        R.simpleList (_in_rows input) $ \r ->
+        flip mapM (_in_rows input) $ \row ->
           R.divClass "row" $ do
-            flip mapM_ [minBound..] $ \h ->
+            flip mapM_ [minBound..] $ \header ->
               R.divClass "cell" $
-                R.dynText $
-                  R.ffor r (_in_cell input h)
+                R.text $
+                  _in_cell input header row
 
-            clone <-
+            cloneButton <-
               R.divClass "cell button" $
                 Button._out_clic <$> (Button.view $
                   Button.defaultIn Icon.clone)
 
-            cloned <-
+            clone <-
               Modal.view $ Modal.In
-                { Modal._in_show    = clone
-                , Modal._in_content = \curtainClick ->
-                  (R.dyn . R.ffor r $ \r2 -> _in_cloneModal input r2 curtainClick)
-                    >>= ReflexUtil.flattenTuple
+                { Modal._in_show    = cloneButton
+                , Modal._in_content = _in_cloneModal input row
                 }
 
-            let isOwner = R.ffor r (_in_isOwner input)
+            let isOwner = _in_isOwner input row
 
-            edit <-
+            let visibleIf cond =
+                  R.elAttr
+                    "div"
+                    (if cond then M.empty else M.singleton "style" "display:none")
+
+            editButton <-
               R.divClass "cell button" $
-                ReflexUtil.divVisibleIf isOwner $
+                visibleIf isOwner $
                   Button._out_clic <$> (Button.view $
                     Button.defaultIn Icon.edit)
 
-            edited <-
+            edit <-
               Modal.view $ Modal.In
-                { Modal._in_show    = edit
-                , Modal._in_content = \curtainClick ->
-                  (R.dyn . R.ffor r $ \r2 -> _in_editModal input r2 curtainClick)
-                    >>= ReflexUtil.flattenTuple
+                { Modal._in_show    = editButton
+                , Modal._in_content = _in_editModal input row
                 }
 
-            delete <-
+            deleteButton <-
               R.divClass "cell button" $
-                ReflexUtil.divVisibleIf isOwner $
+                visibleIf isOwner $
                   Button._out_clic <$> (Button.view $
                     Button.defaultIn Icon.delete)
 
-            deleted <-
+            delete <-
               Modal.view $ Modal.In
-                { Modal._in_show    = delete
-                , Modal._in_content = \curtainClick ->
-                  (R.dyn . R.ffor r $ \r2 -> _in_deleteModal input r2 curtainClick)
-                    >>= ReflexUtil.flattenTuple
+                { Modal._in_show    = deleteButton
+                , Modal._in_content = _in_deleteModal input row
                 }
 
-            return (cloned, edited, deleted)
+            return (clone, edit, delete)
 
-    let add = R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
-        edit = R.switch . R.current . fmap (R.leftmost . map (\(_, a, _) -> a)) $ result
-        delete = R.switch . R.current . fmap (R.leftmost . map (\(_, _, a) -> a)) $ result
+    let add = R.leftmost . map (\(a, _, _) -> a) $ result
+        edit = R.leftmost . map (\(_, a, _) -> a) $ result
+        delete = R.leftmost . map (\(_, _, a) -> a) $ result
 
     return $ Out
       { _out_add = add
diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index a5c1d41..f57b99c 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -45,16 +45,7 @@ fromEvent =
     )
     Loading
 
-view :: forall t m a. MonadWidget t m => (a -> m ()) -> Loadable a -> m ()
-view _ (Loading)  = R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
-view _ (Error e)  = R.text e
-view f (Loaded x) = f x
-
--- view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
--- view _ (Loading)  = do
---   R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank
---   return Nothing
--- view _ (Error e)  = do
---   R.text e
---   return Nothing
--- view f (Loaded x) = Just <$> (f x)
+view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
+view _ (Loading)  = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
+view _ (Error e)  = R.text e >> return Nothing
+view f (Loaded x) = Just <$> f x
diff --git a/client/src/Util/Reflex.hs b/client/src/Util/Reflex.hs
index 9f51c5c..aa5cebb 100644
--- a/client/src/Util/Reflex.hs
+++ b/client/src/Util/Reflex.hs
@@ -45,7 +45,6 @@ flatten e = do
   dyn <- R.holdDyn R.never e
   return $ R.switchDyn dyn
 
-
 flattenTuple
   :: forall t m a b. MonadWidget t m
   => Event t (Event t a, Event t b)
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index c48f325..fedf3d8 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -1,10 +1,14 @@
+{-# LANGUAGE ExplicitForAll #-}
+
 module View.Income.Income
   ( init
   , view
   , In(..)
   ) where
 
+import qualified Data.Text as T
 import           Data.Aeson          (FromJSON)
+import qualified Data.Maybe          as Maybe
 import           Prelude             hiding (init)
 import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
@@ -41,45 +45,38 @@ init = do
 
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
-  -- rec
-    -- incomes <- Reducer.reducer
-    --   { Reducer._in_newPage      = ReflexUtil.flatten (Table._out_newPage <$> table)
-    --   , Reducer._in_currentPage  = ReflexUtil.flatten (Table._out_currentPage <$> table)
-    --   , Reducer._in_addIncome    = ReflexUtil.flatten (Table._out_add <$> table)
-    --   , Reducer._in_editIncome   = ReflexUtil.flatten (Table._out_edit <$> table)
-    --   , Reducer._in_deleteIncome = ReflexUtil.flatten (Table._out_delete <$> table)
-    --   }
-
   rec
     incomes <- Reducer.reducer $ Reducer.In
-      { Reducer._in_newPage      = Pages._out_newPage pages
-      , Reducer._in_currentPage  = Pages._out_currentPage pages
-      , Reducer._in_addIncome    = Table._out_add table
-      , Reducer._in_editIncome   = Table._out_edit table
-      , Reducer._in_deleteIncome = Table._out_delete table
+      { Reducer._in_newPage      = newPage
+      , Reducer._in_currentPage  = currentPage
+      , Reducer._in_addIncome    = addIncome
+      , Reducer._in_editIncome   = editIncome
+      , Reducer._in_deleteIncome = deleteIncome
       }
 
-    table <- Table.view $ Table.In
-      { Table._in_currentUser = _in_currentUser input
-      , Table._in_currency = _in_currency input
-      , Table._in_incomes = R.ffor incomes $ \case
-          Loaded (IncomesAndCount xs _) -> xs
-          _         -> []
-      }
+    let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+        eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
 
-    pages <- Pages.view $ Pages.In
-      { Pages._in_total = R.ffor incomes $ \case
-          Loaded (IncomesAndCount _ n) -> n
-          _         -> 0
-      , Pages._in_perPage = Reducer.perPage
-      }
+    newPage <- eventFromResult $ Pages._out_newPage . snd
+    currentPage <- R.holdDyn 1 newPage
+    addIncome <- eventFromResult $ Table._out_add . fst
+    editIncome <- eventFromResult $ Table._out_edit . fst
+    deleteIncome <- eventFromResult $ Table._out_delete . fst
+
+    result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) ->
+      flip Loadable.view is $ \(IncomesAndCount incomes count) -> do
+        table <- Table.view $ Table.In
+          { Table._in_currentUser = _in_currentUser input
+          , Table._in_currency = _in_currency input
+          , Table._in_incomes = incomes
+          }
+
+        pages <- Pages.view $ Pages.In
+          { Pages._in_total = R.constDyn count
+          , Pages._in_perPage = Reducer.perPage
+          , Pages._in_page = p
+          }
 
-  -- -- table :: Event t (Maybe (Table.Out t))
-  -- table <- R.dyn . R.ffor incomes . Loadable.view $ \incomes ->
-  --   Table.view $ Table.In
-  --     { Table._in_currentUser = _in_currentUser input
-  --     , Table._in_currency = _in_currency input
-  --     , Table._in_incomes = incomes
-  --     }
+        return (table, pages)
 
   return ()
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 6d69c19..9b2129f 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -26,7 +26,7 @@ import qualified View.Income.Form        as Form
 data In t = In
   { _in_currentUser :: UserId
   , _in_currency    :: Currency
-  , _in_incomes     :: Dynamic t [Income]
+  , _in_incomes     :: [Income]
   }
 
 data Out t = Out
@@ -40,7 +40,7 @@ view input = do
 
   table <- Table.view $ Table.In
     { Table._in_headerLabel = headerLabel
-    , Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
+    , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input
     , Table._in_cell = cell [] (_in_currency input)
     , Table._in_cloneModal = \income ->
       Form.view $ Form.In
-- 
cgit v1.2.3


From a267f0bb4566389342c3244d3c082dc2453f4615 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 09:22:12 +0100
Subject: Show users in income table

---
 client/src/Component/Appearing.hs | 10 ++++++++++
 client/src/View/App.hs            |  3 +--
 client/src/View/Income/Income.hs  | 24 ++++++------------------
 client/src/View/Income/Table.hs   |  3 ++-
 4 files changed, 19 insertions(+), 21 deletions(-)
 create mode 100644 client/src/Component/Appearing.hs

(limited to 'client/src')

diff --git a/client/src/Component/Appearing.hs b/client/src/Component/Appearing.hs
new file mode 100644
index 0000000..e0144ca
--- /dev/null
+++ b/client/src/Component/Appearing.hs
@@ -0,0 +1,10 @@
+module Component.Appearing
+  ( view
+  ) where
+
+import           Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+view :: forall t m a. MonadWidget t m => m a -> m a
+view =
+  R.divClass "g-Appearing"
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 1e26417..d305d00 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -67,11 +67,10 @@ signedWidget init route = do
         }
 
     IncomeRoute -> do
-      incomeInit <- Income.init
       Income.view $ Income.In
         { Income._in_currentUser = _init_currentUser init
         , Income._in_currency = _init_currency init
-        , Income._in_init = incomeInit
+        , Income._in_users = _init_users init
         }
 
     NotFoundRoute ->
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index fedf3d8..d31775a 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -1,20 +1,18 @@
 {-# LANGUAGE ExplicitForAll #-}
 
 module View.Income.Income
-  ( init
-  , view
+  ( view
   , In(..)
   ) where
 
-import qualified Data.Text as T
 import           Data.Aeson          (FromJSON)
 import qualified Data.Maybe          as Maybe
-import           Prelude             hiding (init)
+import qualified Data.Text           as T
 import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
 import           Common.Model        (Currency, Income (..),
-                                      IncomesAndCount (..), UserId)
+                                      IncomesAndCount (..), User, UserId)
 
 import qualified Component.Pages     as Pages
 import           Loadable            (Loadable (..))
@@ -27,22 +25,11 @@ import qualified View.Income.Reducer as Reducer
 import qualified View.Income.Table   as Table
 
 data In t = In
-  { _in_currentUser :: UserId
+  { _in_users       :: [User]
+  , _in_currentUser :: UserId
   , _in_currency    :: Currency
-  , _in_init        :: Dynamic t (Loadable Init)
   }
 
-init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
-init = do
-  users <- AjaxUtil.getNow "api/users"
-  incomes <- AjaxUtil.getNow "api/incomes"
-  payments <- AjaxUtil.getNow "api/payments"
-  return $ do
-    us <- users
-    is <- incomes
-    ps <- payments
-    return $ Init <$> us <*> is <*> ps
-
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
   rec
@@ -69,6 +56,7 @@ view input = do
           { Table._in_currentUser = _in_currentUser input
           , Table._in_currency = _in_currency input
           , Table._in_incomes = incomes
+          , Table._in_users = _in_users input
           }
 
         pages <- Pages.view $ Pages.In
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 9b2129f..32ab27b 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -27,6 +27,7 @@ data In t = In
   { _in_currentUser :: UserId
   , _in_currency    :: Currency
   , _in_incomes     :: [Income]
+  , _in_users       :: [User]
   }
 
 data Out t = Out
@@ -41,7 +42,7 @@ view input = do
   table <- Table.view $ Table.In
     { Table._in_headerLabel = headerLabel
     , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input
-    , Table._in_cell = cell [] (_in_currency input)
+    , Table._in_cell = cell (_in_users input) (_in_currency input)
     , Table._in_cloneModal = \income ->
       Form.view $ Form.In
         { Form._in_operation = Form.Clone income
-- 
cgit v1.2.3


From 9dbb4e6f7c2f0edc1126626e2ff498144c6b9947 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 11:28:42 +0100
Subject: Show income header

---
 client/src/View/Income/Header.hs  | 35 ++++++++++++-----------------------
 client/src/View/Income/Income.hs  | 29 ++++++++++++++++++-----------
 client/src/View/Income/Reducer.hs |  8 ++++----
 3 files changed, 34 insertions(+), 38 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 8e82525..8451ee4 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -5,13 +5,15 @@ module View.Income.Header
   ) where
 
 import           Control.Monad.IO.Class (liftIO)
+import qualified Data.Map               as M
 import qualified Data.Maybe             as Maybe
 import qualified Data.Text              as T
 import qualified Data.Time.Clock        as Clock
 import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, Income (..), User (..))
+import           Common.Model           (Currency, Income (..),
+                                         IncomeHeader (..), User (..))
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
@@ -23,9 +25,9 @@ import qualified View.Income.Form       as Form
 import           View.Income.Init       (Init (..))
 
 data In t = In
-  { _in_init     :: Init
+  { _in_users    :: [User]
+  , _in_header   :: IncomeHeader
   , _in_currency :: Currency
-  , _in_incomes  :: Dynamic t [Income]
   }
 
 data Out t = Out
@@ -38,11 +40,11 @@ view input =
 
     currentTime <- liftIO Clock.getCurrentTime
 
-    R.dyn . R.ffor useIncomesFrom $ \case
-      (Nothing, _) ->
+    case _incomeHeader_since $ _in_header input of
+      Nothing ->
         R.blank
 
-      (Just since, incomes) ->
+      Just since ->
         R.el "div" $ do
 
           R.el "h1" $ do
@@ -50,15 +52,13 @@ view input =
             R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day))
 
           R.el "ul" $
-            flip mapM_ (_init_users init) $ \user ->
+            flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) ->
               R.el "li" $
-                R.text $ do
-                  let userIncomes = filter ((==) (_user_id user) . _income_userId) incomes
+                R.text $
                   T.intercalate " "
-                    [ _user_name user
+                    [ Maybe.fromMaybe "" . fmap _user_name $ CM.findUser userId (_in_users input)
                     , "−"
-                    , Format.price (_in_currency input) $
-                      CM.cumulativeIncomesSince currentTime since userIncomes
+                    , Format.price (_in_currency input) amount
                     ]
 
     R.divClass "titleButton" $ do
@@ -78,14 +78,3 @@ view input =
       return $ Out
         { _out_add = addIncome
         }
-
-  where
-    init = _in_init input
-
-    useIncomesFrom = R.ffor (_in_incomes input) $ \incomes ->
-      ( CM.useIncomesFrom
-        (map _user_id $_init_users init)
-        incomes
-        (_init_payments init)
-      , incomes
-      )
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index d31775a..d82ab4d 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -11,15 +11,15 @@ import qualified Data.Text           as T
 import           Reflex.Dom          (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom          as R
 
-import           Common.Model        (Currency, Income (..),
-                                      IncomesAndCount (..), User, UserId)
+import           Common.Model        (Currency, Income (..), IncomePage (..),
+                                      User, UserId)
 
 import qualified Component.Pages     as Pages
 import           Loadable            (Loadable (..))
 import qualified Loadable
 import qualified Util.Ajax           as AjaxUtil
 import qualified Util.Reflex         as ReflexUtil
--- import qualified View.Income.Header as Header
+import qualified View.Income.Header  as Header
 import           View.Income.Init    (Init (..))
 import qualified View.Income.Reducer as Reducer
 import qualified View.Income.Table   as Table
@@ -36,22 +36,29 @@ view input = do
     incomes <- Reducer.reducer $ Reducer.In
       { Reducer._in_newPage      = newPage
       , Reducer._in_currentPage  = currentPage
-      , Reducer._in_addIncome    = addIncome
+      , Reducer._in_addIncome    = R.leftmost [headerAddIncome, tableAddIncome]
       , Reducer._in_editIncome   = editIncome
       , Reducer._in_deleteIncome = deleteIncome
       }
 
-    let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+    let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
         eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
 
-    newPage <- eventFromResult $ Pages._out_newPage . snd
+    newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
     currentPage <- R.holdDyn 1 newPage
-    addIncome <- eventFromResult $ Table._out_add . fst
-    editIncome <- eventFromResult $ Table._out_edit . fst
-    deleteIncome <- eventFromResult $ Table._out_delete . fst
+    headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
+    tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
+    editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
+    deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
     result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) ->
-      flip Loadable.view is $ \(IncomesAndCount incomes count) -> do
+      flip Loadable.view is $ \(IncomePage header incomes count) -> do
+        header <- Header.view $ Header.In
+          { Header._in_users = _in_users input
+          , Header._in_header = header
+          , Header._in_currency = _in_currency input
+          }
+
         table <- Table.view $ Table.In
           { Table._in_currentUser = _in_currentUser input
           , Table._in_currency = _in_currency input
@@ -65,6 +72,6 @@ view input = do
           , Pages._in_page = p
           }
 
-        return (table, pages)
+        return (header, table, pages)
 
   return ()
diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs
index 5b346cb..092d9b3 100644
--- a/client/src/View/Income/Reducer.hs
+++ b/client/src/View/Income/Reducer.hs
@@ -9,7 +9,7 @@ import qualified Data.Text    as T
 import           Reflex.Dom   (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom   as R
 
-import           Common.Model (IncomesAndCount)
+import           Common.Model (IncomePage)
 
 import           Loadable     (Loadable (..))
 import qualified Loadable     as Loadable
@@ -28,9 +28,9 @@ data In t a b c = In
 
 data Action
   = LoadPage Int
-  | GetResult (Either Text IncomesAndCount)
+  | GetResult (Either Text IncomePage)
 
-reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomesAndCount))
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage))
 reducer input = do
 
   postBuild <- R.getPostBuild
@@ -60,7 +60,7 @@ reducer input = do
 
   where
     pageUrl p =
-      "api/v2/incomes?page="
+      "api/incomes?page="
       <> (T.pack . show $ p)
       <> "&perPage="
       <> (T.pack . show $ perPage)
-- 
cgit v1.2.3


From 182f3d3fea9985c0e403087fe253981c68e57102 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 11:33:20 +0100
Subject: Fix payment page

---
 client/src/View/Payment/Payment.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'client/src')

diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index f86acd8..e72577f 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -29,7 +29,7 @@ init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
 init = do
   users <- AjaxUtil.getNow "api/users"
   payments <- AjaxUtil.getNow "api/payments"
-  incomes <- AjaxUtil.getNow "api/incomes"
+  incomes <- AjaxUtil.getNow "api/deprecated/incomes"
   categories <- AjaxUtil.getNow "api/categories"
   paymentCategories <- AjaxUtil.getNow "api/paymentCategories"
   return $ do
-- 
cgit v1.2.3


From 0f85cbd8ee736b1996e3966bac1f5e47ed7d27a9 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 15:47:11 +0100
Subject: Fetch the first payment date instead of every payment to get
 cumulative income

---
 client/src/Util/Date.hs          | 12 ------------
 client/src/View/Income/Header.hs |  4 +---
 2 files changed, 1 insertion(+), 15 deletions(-)
 delete mode 100644 client/src/Util/Date.hs

(limited to 'client/src')

diff --git a/client/src/Util/Date.hs b/client/src/Util/Date.hs
deleted file mode 100644
index 8fad881..0000000
--- a/client/src/Util/Date.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Util.Date
-  ( utcToLocalDay
-  ) where
-
-import           Data.Time.Calendar  (Day)
-import           Data.Time.Clock     (UTCTime)
-import qualified Data.Time.LocalTime as LocalTime
-
-utcToLocalDay :: UTCTime -> IO Day
-utcToLocalDay time = do
-  timezone <- LocalTime.getCurrentTimeZone
-  return . LocalTime.localDay $ LocalTime.utcToLocalTime timezone time
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 8451ee4..9e1c5b6 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -20,7 +20,6 @@ import qualified Common.View.Format     as Format
 
 import qualified Component.Button       as Button
 import qualified Component.Modal        as Modal
-import qualified Util.Date              as DateUtil
 import qualified View.Income.Form       as Form
 import           View.Income.Init       (Init (..))
 
@@ -48,8 +47,7 @@ view input =
         R.el "div" $ do
 
           R.el "h1" $ do
-            day <- liftIO $ DateUtil.utcToLocalDay since
-            R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay day))
+            R.text $ Msg.get (Msg.Income_CumulativeSince (Format.longDay since))
 
           R.el "ul" $
             flip mapM_ (M.toList . _incomeHeader_byUser $ _in_header input) $ \(userId, amount) ->
-- 
cgit v1.2.3


From 4c79ca374e030454f62a467fb4f2197d372e9bc1 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 15:53:46 +0100
Subject: Fix select input style

---
 client/src/Component/Select.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'client/src')

diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 375ae06..70f5f58 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -35,7 +35,7 @@ view input = do
   rec
     let containerAttr = R.ffor showedError (\e ->
           M.singleton "class" $ T.intercalate " "
-            [ "input"
+            [ "input selectInput"
             , if Maybe.isJust e then "error" else ""
             ])
 
-- 
cgit v1.2.3


From 58f6c4e25f5f20f1b608242c83786e2f13947804 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 3 Nov 2019 16:09:30 +0100
Subject: Delay modal event to let time for the modal to disappear

---
 client/src/Component/Modal.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'client/src')

diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 50af469..b0533e2 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -71,7 +71,8 @@ view input = do
     let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn
     let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
 
-  return content
+  -- Delay the event in order to let time for the modal to disappear
+  R.delay (0.3 :: NominalDiffTime) content
 
 getAttributes :: Text -> LM.Map Text Text
 getAttributes modalClass =
-- 
cgit v1.2.3


From f4f24158a46d8c0975f1b8813bbdbbeebad8c108 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 6 Nov 2019 19:44:15 +0100
Subject: Show the payment table with server side paging

---
 client/src/Component/Modal.hs      |   2 +-
 client/src/Component/Table.hs      |  21 +--
 client/src/View/App.hs             |   7 +-
 client/src/View/Income/Form.hs     |  18 +-
 client/src/View/Income/Table.hs    |   8 +-
 client/src/View/Payment/Add.hs     |  55 ------
 client/src/View/Payment/Clone.hs   |  61 ------
 client/src/View/Payment/Delete.hs  |  58 ------
 client/src/View/Payment/Edit.hs    |  56 ------
 client/src/View/Payment/Form.hs    | 137 +++++++++-----
 client/src/View/Payment/Header.hs  |   8 +-
 client/src/View/Payment/Pages.hs   |  87 ---------
 client/src/View/Payment/Payment.hs | 367 ++++++++++++++++++++-----------------
 client/src/View/Payment/Reducer.hs |  66 +++++++
 client/src/View/Payment/Table.hs   | 315 +++++++++++++------------------
 15 files changed, 516 insertions(+), 750 deletions(-)
 delete mode 100644 client/src/View/Payment/Add.hs
 delete mode 100644 client/src/View/Payment/Clone.hs
 delete mode 100644 client/src/View/Payment/Delete.hs
 delete mode 100644 client/src/View/Payment/Edit.hs
 delete mode 100644 client/src/View/Payment/Pages.hs
 create mode 100644 client/src/View/Payment/Reducer.hs

(limited to 'client/src')

diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index b0533e2..08f2e74 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -72,7 +72,7 @@ view input = do
     let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
 
   -- Delay the event in order to let time for the modal to disappear
-  R.delay (0.3 :: NominalDiffTime) content
+  R.delay (0.5 :: NominalDiffTime) content
 
 getAttributes :: Text -> LM.Map Text Text
 getAttributes modalClass =
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 3b9ec24..2869c2d 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -4,7 +4,7 @@ module Component.Table
   , Out(..)
   ) where
 
-import qualified Data.Map as M
+import qualified Data.Map         as M
 import           Data.Text        (Text)
 import           Reflex.Dom       (Event, MonadWidget)
 import qualified Reflex.Dom       as R
@@ -14,23 +14,23 @@ import qualified Component.Modal  as Modal
 import qualified Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
-data In m t h r a = In
+data In m t h r a b c = In
   { _in_headerLabel :: h -> Text
   , _in_rows        :: [r]
-  , _in_cell        :: h -> r -> Text
+  , _in_cell        :: h -> r -> m ()
   , _in_cloneModal  :: r -> Modal.Content t m a
-  , _in_editModal   :: r -> Modal.Content t m a
-  , _in_deleteModal :: r -> Modal.Content t m a
+  , _in_editModal   :: r -> Modal.Content t m b
+  , _in_deleteModal :: r -> Modal.Content t m c
   , _in_isOwner     :: r -> Bool
   }
 
-data Out t a = Out
+data Out t a b c = Out
   { _out_add    :: Event t a
-  , _out_edit   :: Event t a
-  , _out_delete :: Event t a
+  , _out_edit   :: Event t b
+  , _out_delete :: Event t c
   }
 
-view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h)  => In m t h r a -> m (Out t a)
+view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h)  => In m t h r a b c-> m (Out t a b c)
 view input =
   R.divClass "table" $ do
     rec
@@ -49,8 +49,7 @@ view input =
           R.divClass "row" $ do
             flip mapM_ [minBound..] $ \header ->
               R.divClass "cell" $
-                R.text $
-                  _in_cell input header row
+                _in_cell input header row
 
             cloneButton <-
               R.divClass "cell button" $
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index d305d00..2b346af 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -58,15 +58,14 @@ widget initResult =
 signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
-    RootRoute -> do
-      paymentInit <- Payment.init
+    RootRoute ->
       Payment.view $ Payment.In
         { Payment._in_currentUser = _init_currentUser init
         , Payment._in_currency = _init_currency init
-        , Payment._in_init = paymentInit
+        , Payment._in_users = _init_users init
         }
 
-    IncomeRoute -> do
+    IncomeRoute ->
       Income.view $ Income.In
         { Income._in_currentUser = _init_currentUser init
         , Income._in_currency = _init_currency init
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index a4f7de8..ff6e55e 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -27,7 +27,7 @@ import qualified Component.Modal          as Modal
 import qualified Component.ModalForm      as ModalForm
 import qualified Util.Ajax                as Ajax
 
-data In t = In
+data In = In
   { _in_operation :: Operation
   }
 
@@ -36,7 +36,7 @@ data Operation
   | Clone Income
   | Edit Income
 
-view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Income
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income
 view input cancel = do
 
   rec
@@ -94,14 +94,14 @@ view input cancel = do
 
     amount =
       case op of
-        New          -> ""
-        Clone income -> T.pack . show . _income_amount $ income
-        Edit income  -> T.pack . show . _income_amount $ income
+        New     -> ""
+        Clone i -> T.pack . show . _income_amount $ i
+        Edit i  -> T.pack . show . _income_amount $ i
 
     date currentDay =
       case op of
-        Edit income -> _income_date income
-        _           -> currentDay
+        Edit i -> _income_date i
+        _      -> currentDay
 
     ajax =
       case op of
@@ -115,5 +115,5 @@ view input cancel = do
 
     mkPayload =
       case op of
-        Edit income -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id income) a b
-        _         -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
+        Edit i -> \a b -> Aeson.toJSON $ EditIncomeForm (_income_id i) a b
+        _      -> \a b -> Aeson.toJSON $ CreateIncomeForm a b
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index 32ab27b..c623acb 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -80,14 +80,14 @@ headerLabel UserHeader   = Msg.get Msg.Income_Name
 headerLabel DateHeader   = Msg.get Msg.Income_Date
 headerLabel AmountHeader = Msg.get Msg.Income_Amount
 
-cell :: [User] -> Currency -> Header -> Income -> Text
+cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Income -> m ()
 cell users currency header income =
   case header of
     UserHeader ->
-      Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
+      R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_income_userId income) users
 
     DateHeader ->
-      Format.longDay . _income_date $ income
+      R.text . Format.longDay . _income_date $ income
 
     AmountHeader ->
-      Format.price currency . _income_amount $ income
+      R.text . Format.price currency . _income_amount $ income
diff --git a/client/src/View/Payment/Add.hs b/client/src/View/Payment/Add.hs
deleted file mode 100644
index e983465..0000000
--- a/client/src/View/Payment/Add.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module View.Payment.Add
-  ( view
-  , In(..)
-  ) where
-
-import           Control.Monad          (join)
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.Text              as T
-import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Category (..), CreatePaymentForm (..),
-                                         Frequency (..), Payment (..),
-                                         PaymentCategory (..),
-                                         SavedPayment (..))
-import qualified Common.Msg             as Msg
-import qualified Common.Util.Time       as TimeUtil
-import qualified Component.Modal        as Modal
-import qualified Util.Ajax              as Ajax
-import qualified Util.Reflex            as ReflexUtil
-import qualified View.Payment.Form      as Form
-
-data In t = In
-  { _in_categories        :: [Category]
-  , _in_paymentCategories :: Dynamic t [PaymentCategory]
-  , _in_frequency         :: Dynamic t Frequency
-  }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
-view input cancel = do
-
-  currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
-
-  formOutput <- R.dyn $ do
-    paymentCategories <- _in_paymentCategories input
-    frequency <- _in_frequency input
-    return $ Form.view $ Form.In
-      { Form._in_cancel = cancel
-      , Form._in_headerLabel = Msg.get Msg.Payment_Add
-      , Form._in_categories = _in_categories input
-      , Form._in_paymentCategories = paymentCategories
-      , Form._in_name = ""
-      , Form._in_cost = ""
-      , Form._in_date = currentDay
-      , Form._in_category = -1
-      , Form._in_frequency = frequency
-      , Form._in_mkPayload = CreatePaymentForm
-      , Form._in_ajax = Ajax.post
-      }
-
-  hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
-  addPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
-
-  return (hide, addPayment)
diff --git a/client/src/View/Payment/Clone.hs b/client/src/View/Payment/Clone.hs
deleted file mode 100644
index 82b0c27..0000000
--- a/client/src/View/Payment/Clone.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-module View.Payment.Clone
-  ( In(..)
-  , view
-  ) where
-
-import qualified Control.Monad          as Monad
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.Text              as T
-import qualified Data.Time.Clock        as Time
-import           Reflex.Dom             (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Category (..), CategoryId,
-                                         CreatePaymentForm (..), Frequency (..),
-                                         Payment (..), PaymentCategory (..),
-                                         SavedPayment (..))
-import qualified Common.Msg             as Msg
-import qualified Common.Util.Time       as TimeUtil
-import qualified Component.Modal        as Modal
-import qualified Util.Ajax              as Ajax
-import qualified Util.Reflex            as ReflexUtil
-import qualified View.Payment.Form      as Form
-
-data In t = In
-  { _in_show              :: Event t ()
-  , _in_categories        :: [Category]
-  , _in_paymentCategories :: Dynamic t [PaymentCategory]
-  , _in_payment           :: Dynamic t Payment
-  , _in_category          :: Dynamic t CategoryId
-  }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
-view input cancel = do
-
-  currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
-
-  form <- R.dyn $ do
-    paymentCategories <- _in_paymentCategories input
-    payment <- _in_payment input
-    category <- _in_category input
-    return . Form.view $ Form.In
-      { Form._in_cancel = cancel
-      , Form._in_headerLabel = Msg.get Msg.Payment_CloneLong
-      , Form._in_categories = _in_categories input
-      , Form._in_paymentCategories = paymentCategories
-      , Form._in_name = _payment_name payment
-      , Form._in_cost = T.pack . show . _payment_cost $ payment
-      , Form._in_date = currentDay
-      , Form._in_category = category
-      , Form._in_frequency = _payment_frequency payment
-      , Form._in_mkPayload = CreatePaymentForm
-      , Form._in_ajax = Ajax.post
-      }
-
-  hide <- ReflexUtil.flatten (Form._output_hide <$> form)
-  clonePayment <- ReflexUtil.flatten (Form._output_addPayment <$> form)
-
-  return $
-    ( hide
-    , clonePayment
-    )
diff --git a/client/src/View/Payment/Delete.hs b/client/src/View/Payment/Delete.hs
deleted file mode 100644
index e5e7219..0000000
--- a/client/src/View/Payment/Delete.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-module View.Payment.Delete
-  ( In(..)
-  , view
-  ) where
-
-import           Data.Text        (Text)
-import qualified Data.Text        as T
-import           Reflex.Dom       (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom       as R
-
-import           Common.Model     (Payment (..))
-import qualified Common.Msg       as Msg
-import qualified Component.Button as Button
-import qualified Component.Modal  as Modal
-import qualified Util.Ajax        as Ajax
-import qualified Util.Either      as EitherUtil
-import qualified Util.WaitFor     as WaitFor
-
-data In t = In
-  { _in_payment :: Dynamic t Payment
-  }
-
-view :: forall t m. MonadWidget t m => (In t) -> Modal.Content t m Payment
-view input _ =
-  R.divClass "delete" $ do
-    R.divClass "deleteHeader" $ R.text $ Msg.get Msg.Payment_DeleteConfirm
-
-    R.divClass "deleteContent" $ do
-
-      (confirm, cancel) <- R.divClass "buttons" $ do
-
-        cancel <- Button._out_clic <$> (Button.view $
-          (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
-            { Button._in_class = R.constDyn "undo" })
-
-        rec
-          confirm <- Button._out_clic <$> (Button.view $
-            (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
-              { Button._in_class = R.constDyn "confirm"
-              , Button._in_submit = True
-              , Button._in_waiting = waiting
-              })
-
-          let url =
-                R.ffor (_in_payment input) (\id ->
-                  T.concat ["/api/payment/", T.pack . show $ _payment_id id]
-                )
-
-          (result, waiting) <- WaitFor.waitFor
-            (Ajax.delete url)
-            confirm
-
-        return (R.fmapMaybe EitherUtil.eitherToMaybe result, cancel)
-
-      return $
-        ( R.leftmost [ cancel, () <$ confirm ]
-        , R.tag (R.current $ _in_payment input) confirm
-        )
diff --git a/client/src/View/Payment/Edit.hs b/client/src/View/Payment/Edit.hs
deleted file mode 100644
index 5cb4537..0000000
--- a/client/src/View/Payment/Edit.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module View.Payment.Edit
-  ( In(..)
-  , view
-  ) where
-
-import qualified Control.Monad     as Monad
-import qualified Data.Text         as T
-import           Reflex.Dom        (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom        as R
-
-import           Common.Model      (Category (..), CategoryId,
-                                    EditPaymentForm (..), Frequency (..),
-                                    Payment (..), PaymentCategory (..),
-                                    SavedPayment (..))
-import qualified Common.Msg        as Msg
-import qualified Component.Modal   as Modal
-import qualified Util.Ajax         as Ajax
-import qualified Util.Reflex       as ReflexUtil
-import qualified View.Payment.Form as Form
-
-data In t = In
-  { _in_show              :: Event t ()
-  , _in_categories        :: [Category]
-  , _in_paymentCategories :: Dynamic t [PaymentCategory]
-  , _in_payment           :: Dynamic t Payment
-  , _in_category          :: Dynamic t CategoryId
-  }
-
-view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
-view input cancel = do
-
-  formOutput <- R.dyn $ do
-    paymentCategories <- _in_paymentCategories input
-    payment <- _in_payment input
-    category <- _in_category input
-    return . Form.view $ Form.In
-      { Form._in_cancel = cancel
-      , Form._in_headerLabel = Msg.get Msg.Payment_EditLong
-      , Form._in_categories = _in_categories input
-      , Form._in_paymentCategories = paymentCategories
-      , Form._in_name = _payment_name payment
-      , Form._in_cost = T.pack . show . _payment_cost $ payment
-      , Form._in_date = _payment_date payment
-      , Form._in_category = category
-      , Form._in_frequency = _payment_frequency payment
-      , Form._in_mkPayload = EditPaymentForm (_payment_id payment)
-      , Form._in_ajax = Ajax.put
-      }
-
-  hide <- ReflexUtil.flatten (Form._output_hide <$> formOutput)
-  editPayment <- ReflexUtil.flatten (Form._output_addPayment <$> formOutput)
-
-  return $
-    ( hide
-    , editPayment
-    )
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 29768aa..99b0848 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -1,10 +1,12 @@
 module View.Payment.Form
   ( view
   , In(..)
-  , Out(..)
+  , Operation(..)
   ) where
 
-import           Data.Aeson                (ToJSON)
+import           Control.Monad.IO.Class    (liftIO)
+import           Data.Aeson                (Value)
+import qualified Data.Aeson                as Aeson
 import qualified Data.List                 as L
 import           Data.List.NonEmpty        (NonEmpty)
 import qualified Data.Map                  as M
@@ -13,6 +15,7 @@ import           Data.Text                 (Text)
 import qualified Data.Text                 as T
 import           Data.Time.Calendar        (Day)
 import qualified Data.Time.Calendar        as Calendar
+import qualified Data.Time.Clock           as Clock
 import           Data.Validation           (Validation)
 import qualified Data.Validation           as V
 import           Reflex.Dom                (Dynamic, Event, MonadWidget)
@@ -20,103 +23,98 @@ import qualified Reflex.Dom                as R
 import qualified Text.Read                 as T
 
 import           Common.Model              (Category (..), CategoryId,
+                                            CreatePaymentForm (..),
+                                            EditPaymentForm (..),
                                             Frequency (..), Payment (..),
                                             PaymentCategory (..),
                                             SavedPayment (..))
 import qualified Common.Msg                as Msg
+import qualified Common.Util.Time          as TimeUtil
 import qualified Common.Validation.Payment as PaymentValidation
+
 import qualified Component.Input           as Input
+import qualified Component.Modal           as Modal
 import qualified Component.ModalForm       as ModalForm
 import qualified Component.Select          as Select
+import qualified Util.Ajax                 as Ajax
 import qualified Util.Validation           as ValidationUtil
 
-data In m t a = In
-  { _in_cancel            :: Event t ()
-  , _in_headerLabel       :: Text
-  , _in_categories        :: [Category]
+data In = In
+  { _in_categories        :: [Category]
   , _in_paymentCategories :: [PaymentCategory]
-  , _in_name              :: Text
-  , _in_cost              :: Text
-  , _in_date              :: Day
-  , _in_category          :: CategoryId
-  , _in_frequency         :: Frequency
-  , _in_mkPayload         :: Text -> Text -> Text -> CategoryId -> Frequency -> a
-  , _in_ajax              :: Text -> Event t a -> m (Event t (Either Text SavedPayment))
+  , _in_operation         :: Operation
   }
 
-data Out t = Out
-  { _output_hide       :: Event t ()
-  , _output_addPayment :: Event t SavedPayment
-  }
+data Operation
+  = New Frequency
+  | Clone Payment
+  | Edit Payment
 
-view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t)
-view input = do
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment
+view input cancel = do
   rec
     let reset = R.leftmost
           [ "" <$ ModalForm._out_cancel modalForm
           , "" <$ ModalForm._out_validate modalForm
-          , "" <$ _in_cancel input
+          , "" <$ cancel
           ]
 
     modalForm <- ModalForm.view $ ModalForm.In
-      { ModalForm._in_headerLabel = _in_headerLabel input
-      , ModalForm._in_ajax        = _in_ajax input "/api/payment"
+      { ModalForm._in_headerLabel = headerLabel
+      , ModalForm._in_ajax        = ajax "/api/payment"
       , ModalForm._in_form        = form reset (ModalForm._out_confirm modalForm)
       }
 
-  return $ Out
-    { _output_hide = ModalForm._out_hide modalForm
-    , _output_addPayment = ModalForm._out_validate modalForm
-    }
+  return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm)
 
   where
+
     form
       :: Event t String
       -> Event t ()
-      -> m (Dynamic t (Validation (NonEmpty Text) a))
+      -> m (Dynamic t (Validation (NonEmpty Text) Value))
     form reset confirm = do
       name <- Input.view
         (Input.defaultIn
           { Input._in_label = Msg.get Msg.Payment_Name
-          , Input._in_initialValue = _in_name input
+          , Input._in_initialValue = name
           , Input._in_validation = PaymentValidation.name
           })
-        (_in_name input <$ reset)
+        (name <$ reset)
         confirm
 
       cost <- Input._out_raw <$> (Input.view
         (Input.defaultIn
           { Input._in_label = Msg.get Msg.Payment_Cost
-          , Input._in_initialValue = _in_cost input
+          , Input._in_initialValue = cost
           , Input._in_validation = PaymentValidation.cost
           })
-        (_in_cost input <$ reset)
+        (cost <$ reset)
         confirm)
 
-      let initialDate = T.pack . Calendar.showGregorian . _in_date $ input
+      d <- date
 
       date <- Input._out_raw <$> (Input.view
         (Input.defaultIn
           { Input._in_label = Msg.get Msg.Payment_Date
-          , Input._in_initialValue = initialDate
+          , Input._in_initialValue = d
           , Input._in_inputType = "date"
           , Input._in_hasResetButton = False
           , Input._in_validation = PaymentValidation.date
           })
-        (initialDate <$ reset)
+        (d <$ reset)
         confirm)
 
       let setCategory =
             R.fmapMaybe id . R.updated $
-              R.ffor (Input._out_raw name) $ \name ->
-                findCategory name (_in_paymentCategories input)
+              R.ffor (Input._out_raw name) findCategory
 
       category <- Select._out_value <$> (Select.view $ Select.In
         { Select._in_label = Msg.get Msg.Payment_Category
-        , Select._in_initialValue = _in_category input
+        , Select._in_initialValue = category
         , Select._in_value = setCategory
         , Select._in_values = R.constDyn categories
-        , Select._in_reset = _in_category input <$ reset
+        , Select._in_reset = category <$ reset
         , Select._in_isValid = PaymentValidation.category (map _category_id $ _in_categories input)
         , Select._in_validate = confirm
         })
@@ -126,12 +124,12 @@ view input = do
         c <- cost
         d <- date
         cat <- category
-        return ((_in_mkPayload input)
+        return (mkPayload
           <$> ValidationUtil.nelError n
           <*> V.Success c
           <*> V.Success d
           <*> ValidationUtil.nelError cat
-          <*> V.Success (_in_frequency input))
+          <*> V.Success frequency)
 
     frequencies =
       M.fromList
@@ -142,7 +140,58 @@ view input = do
     categories = M.fromList . flip map (_in_categories input) $ \c ->
       (_category_id c, _category_name c)
 
-findCategory :: Text -> [PaymentCategory] -> Maybe CategoryId
-findCategory paymentName =
-  fmap _paymentCategory_category
-    . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
+    op = _in_operation input
+
+    name =
+      case op of
+        New _   -> ""
+        Clone p -> _payment_name p
+        Edit p  -> _payment_name p
+
+    cost =
+      case op of
+        New _   -> ""
+        Clone p -> T.pack . show . _payment_cost $ p
+        Edit p  -> T.pack . show . _payment_cost $ p
+
+    date = do
+      currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay
+      return . T.pack . Calendar.showGregorian $
+        case op of
+          New _   -> currentDay
+          Clone p -> currentDay
+          Edit p  -> _payment_date p
+
+    category =
+      case op of
+        New _   -> -1
+        Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
+        Edit p  -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
+
+    frequency =
+      case op of
+        New f   -> f
+        Clone p -> _payment_frequency p
+        Edit p  -> _payment_frequency p
+
+    headerLabel =
+      case op of
+        New _   -> Msg.get Msg.Payment_Add
+        Clone _ -> Msg.get Msg.Payment_CloneLong
+        Edit _  -> Msg.get Msg.Payment_EditLong
+
+    ajax =
+      case op of
+        Edit _ -> Ajax.put
+        _      -> Ajax.post
+
+    mkPayload =
+      case op of
+        Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e
+        _      -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e
+
+    findCategory :: Text -> Maybe CategoryId
+    findCategory paymentName =
+      fmap _paymentCategory_category
+        . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
+        $ (_in_paymentCategories input)
diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
index 00987a3..c8ca347 100644
--- a/client/src/View/Payment/Header.hs
+++ b/client/src/View/Payment/Header.hs
@@ -32,7 +32,7 @@ import qualified Component.Input        as Input
 import qualified Component.Modal        as Modal
 import qualified Component.Select       as Select
 import qualified Util.List              as L
-import qualified View.Payment.Add       as Add
+import qualified View.Payment.Form      as Form
 import           View.Payment.Init      (Init (..))
 
 data In t = In
@@ -120,11 +120,7 @@ payerAndAdd incomes payments users categories paymentCategories currency frequen
 
     Modal.view $ Modal.In
       { Modal._in_show    = addPayment
-      , Modal._in_content = Add.view $ Add.In
-          { Add._in_categories = categories
-          , Add._in_paymentCategories = paymentCategories
-          , Add._in_frequency = frequency
-          }
+      , Modal._in_content = \_ -> return (R.never, R.never) -- TODO
       }
 
 searchLine
diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs
deleted file mode 100644
index 9a1902c..0000000
--- a/client/src/View/Payment/Pages.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-module View.Payment.Pages
-  ( view
-  , In(..)
-  , Out(..)
-  ) where
-
-import qualified Data.Text        as T
-import           Reflex.Dom       (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom       as R
-
-import qualified Component.Button as Button
-
-import qualified Util.Reflex      as ReflexUtil
-import qualified View.Icon        as Icon
-
-data In t = In
-  { _in_total   :: Dynamic t Int
-  , _in_perPage :: Int
-  , _in_reset   :: Event t ()
-  }
-
-data Out t = Out
-  { _out_currentPage :: Dynamic t Int
-  }
-
-view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input = do
-  currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
-
-  return $ Out
-    { _out_currentPage = currentPage
-    }
-
-  where
-    total = _in_total input
-    perPage = _in_perPage input
-    reset = _in_reset input
-
-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 <- Button._out_clic <$> (Button.view $ Button.In
-    { Button._in_class   = do
-        cp <- currentPage
-        p <- page
-        if cp == Just p then "page current" else "page"
-    , Button._in_content = content
-    , Button._in_waiting = R.never
-    , Button._in_tabIndex = Nothing
-    , Button._in_submit = False
-    })
-  return . fmap fst $ R.attach (R.current page) clic
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index e72577f..bf0186f 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -1,181 +1,218 @@
 module View.Payment.Payment
-  ( init
-  , view
+  ( view
   , In(..)
   ) where
 
-import           Data.Text           (Text)
-import qualified Data.Text           as T
-import           Data.Time.Clock     (NominalDiffTime)
-import           Prelude             hiding (init)
-import           Reflex.Dom          (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom          as R
-
-import           Common.Model        (Currency, Frequency, Income (..),
-                                      Payment (..), PaymentCategory (..),
-                                      PaymentId, SavedPayment (..), User,
-                                      UserId)
-import qualified Common.Util.Text    as T
-
-import           Loadable            (Loadable (..))
+import qualified Data.Maybe           as Maybe
+import           Data.Text            (Text)
+import qualified Data.Text            as T
+import           Data.Time.Clock      (NominalDiffTime)
+import           Prelude              hiding (init)
+import           Reflex.Dom           (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom           as R
+
+import           Common.Model         (Currency, Frequency, Income (..),
+                                       Payment (..), PaymentCategory (..),
+                                       PaymentId, PaymentPage (..),
+                                       SavedPayment (..), User, UserId)
+import qualified Common.Util.Text     as T
+
+import qualified Component.Pages      as Pages
+import           Loadable             (Loadable (..))
 import qualified Loadable
-import qualified Util.Ajax           as AjaxUtil
-import qualified View.Payment.Header as Header
-import           View.Payment.Init   (Init (..))
-import qualified View.Payment.Pages  as Pages
-import qualified View.Payment.Table  as Table
-
-init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
-init = do
-  users <- AjaxUtil.getNow "api/users"
-  payments <- AjaxUtil.getNow "api/payments"
-  incomes <- AjaxUtil.getNow "api/deprecated/incomes"
-  categories <- AjaxUtil.getNow "api/categories"
-  paymentCategories <- AjaxUtil.getNow "api/paymentCategories"
-  return $ do
-    us <- users
-    ps <- payments
-    is <- incomes
-    cs <- categories
-    pcs <- paymentCategories
-    return $ Init <$> us <*> ps <*> is <*> cs <*> pcs
-
+import qualified Util.Ajax            as AjaxUtil
+import qualified Util.Reflex          as ReflexUtil
+import qualified View.Payment.Header  as Header
+import           View.Payment.Init    (Init (..))
+import qualified View.Payment.Reducer as Reducer
+import qualified View.Payment.Table   as Table
 
 data In t = In
   { _in_currentUser :: UserId
+  , _in_users       :: [User]
   , _in_currency    :: Currency
-  , _in_init        :: Dynamic t (Loadable Init)
   }
 
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
-  R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
-
-    R.elClass "main" "payment" $ do
-      rec
-        let addPayment = R.leftmost
-              [ Header._out_addPayment header
-              , Table._out_addPayment table
-              ]
-
-            paymentsPerPage = 7
-
-        payments <- reducePayments
-          (_init_payments init)
-          (_savedPayment_payment <$> addPayment)
-          (_savedPayment_payment <$> Table._out_editPayment table)
-          (Table._out_deletePayment table)
-
-        paymentCategories <- reducePaymentCategories
-          (_init_paymentCategories init)
-          payments
-          (_savedPayment_paymentCategory <$> addPayment)
-          (_savedPayment_paymentCategory <$> Table._out_editPayment table)
-          (Table._out_deletePayment table)
-
-        (searchNameEvent, searchName) <-
-          debounceSearchName (Header._out_searchName header)
-
-        let searchPayments =
-              getSearchPayments searchName (Header._out_searchFrequency header) payments
-
-        header <- Header.view $ Header.In
-          { Header._in_init = init
-          , Header._in_currency = _in_currency input
-          , Header._in_payments = payments
-          , Header._in_searchPayments = searchPayments
-          , Header._in_paymentCategories = paymentCategories
-          }
-
-        table <- Table.view $ Table.In
-          { Table._in_init = init
-          , Table._in_currency = _in_currency input
-          , Table._in_currentUser = _in_currentUser input
-          , Table._in_currentPage = Pages._out_currentPage pages
-          , Table._in_payments = searchPayments
-          , Table._in_perPage = paymentsPerPage
-          , Table._in_paymentCategories = paymentCategories
-          }
-
-        pages <- Pages.view $ Pages.In
-          { Pages._in_total = length <$> searchPayments
-          , Pages._in_perPage = paymentsPerPage
-          , Pages._in_reset = R.leftmost $
-              [ () <$ searchNameEvent
-              , () <$ Header._out_addPayment header
-              ]
-          }
-
-      pure ()
+
+  categoriesEvent <- (AjaxUtil.getNow "api/categories")
+
+  R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do
+
+    rec
+      payments <- Reducer.reducer $ Reducer.In
+        { Reducer._in_newPage      = newPage
+        , Reducer._in_currentPage  = currentPage
+        , Reducer._in_addPayment    = R.leftmost [headerAddPayment, tableAddPayment]
+        , Reducer._in_editPayment   = editPayment
+        , Reducer._in_deletePayment = deletePayment
+        }
+
+      let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+          eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
+
+      newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
+      currentPage <- R.holdDyn 1 newPage
+      -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
+      let headerAddPayment = R.never
+      tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
+      editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
+      deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
+
+      result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
+        flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do
+          table <- Table.view $ Table.In
+            { Table._in_users = _in_users input
+            , Table._in_currentUser = _in_currentUser input
+            , Table._in_categories = categories
+            , Table._in_currency = _in_currency input
+            , Table._in_payments = payments
+            , Table._in_paymentCategories = paymentCategories
+            }
+
+          pages <- Pages.view $ Pages.In
+            { Pages._in_total = R.constDyn count
+            , Pages._in_perPage = Reducer.perPage
+            , Pages._in_page = p
+            }
+
+          return ((), table, pages)
+
+    return ()
 
   return ()
 
-debounceSearchName
-  :: forall t m. MonadWidget t m
-  => Dynamic t Text
-  -> m (Event t Text, Dynamic t Text)
-debounceSearchName searchName = do
-  event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
-  dynamic <- R.holdDyn "" event
-  return (event, dynamic)
-
-reducePayments
-  :: forall t m. MonadWidget t m
-  => [Payment]
-  -> Event t Payment -- add payment
-  -> Event t Payment -- edit payment
-  -> Event t Payment -- delete payment
-  -> m (Dynamic t [Payment])
-reducePayments initPayments addPayment editPayment deletePayment =
-  R.foldDyn id initPayments $ R.leftmost
-    [ (:) <$> addPayment
-    , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
-    , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
-    ]
-
-reducePaymentCategories
-  :: forall t m. MonadWidget t m
-  => [PaymentCategory]
-  -> Dynamic t [Payment]      -- payments
-  -> Event t PaymentCategory  -- add payment category
-  -> Event t PaymentCategory  -- edit payment category
-  -> Event t Payment          -- delete payment
-  -> m (Dynamic t [PaymentCategory])
-reducePaymentCategories
-  initPaymentCategories
-  payments
-  addPaymentCategory
-  editPaymentCategory
-  deletePayment
-    =
-  R.foldDyn id initPaymentCategories $ R.leftmost
-    [ (:) <$> addPaymentCategory
-    , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
-    , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
-    ]
-  where
-    deletePaymentName =
-      R.attachWithMaybe
-        (\ps p ->
-          if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
-            Nothing
-          else
-            Just (_payment_name p))
-        (R.current payments)
-        deletePayment
-    lowerName = T.toLower . _payment_name
-
-getSearchPayments
-  :: forall t. Reflex t
-  => Dynamic t Text
-  -> Dynamic t Frequency
-  -> Dynamic t [Payment]
-  -> Dynamic t [Payment]
-getSearchPayments name frequency payments = do
-  n <- name
-  f <- frequency
-  ps <- payments
-  pure $ flip filter ps (\p ->
-    (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
-    && (_payment_frequency p == f)
-    ))
+
+-- view :: forall t m. MonadWidget t m => In t -> m ()
+-- view input = do
+--   R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
+--
+--     R.elClass "main" "payment" $ do
+--       rec
+--         let addPayment = R.leftmost
+--               -- [ Header._out_addPayment header
+--               [ Table2._out_addPayment table
+--               ]
+--
+--             paymentsPerPage = 7
+--
+--         payments <- reducePayments
+--           (_init_payments init)
+--           (_savedPayment_payment <$> addPayment)
+--           (_savedPayment_payment <$> Table2._out_editPayment table)
+--           (Table2._out_deletePayment table)
+--
+--         paymentCategories <- reducePaymentCategories
+--           (_init_paymentCategories init)
+--           payments
+--           (_savedPayment_paymentCategory <$> addPayment)
+--           (_savedPayment_paymentCategory <$> Table2._out_editPayment table)
+--           (Table2._out_deletePayment table)
+--
+--         -- (searchNameEvent, searchName) <-
+--         --   debounceSearchName (Header._out_searchName header)
+--
+--         -- let searchPayments =
+--         --       getSearchPayments searchName (Header._out_searchFrequency header) payments
+--
+--         -- header <- Header.view $ Header.In
+--         --   { Header._in_init = init
+--         --   , Header._in_currency = _in_currency input
+--         --   , Header._in_payments = payments
+--         --   , Header._in_searchPayments = searchPayments
+--         --   , Header._in_paymentCategories = paymentCategories
+--         --   }
+--
+--         table <- Table2.view $ Table2.In
+--           { Table2._in_init = init
+--           , Table2._in_currency = _in_currency input
+--           , Table2._in_currentUser = _in_currentUser input
+--           , Table2._in_currentPage = Pages2._out_currentPage pages
+--           , Table2._in_payments = payments
+--           , Table2._in_perPage = paymentsPerPage
+--           , Table2._in_paymentCategories = paymentCategories
+--           }
+--
+--         pages <- Pages2.view $ Pages2.In
+--           { Pages2._in_total = length <$> payments
+--           , Pages2._in_perPage = paymentsPerPage
+--           , Pages2._in_reset = R.never
+--               -- [ () <$ searchNameEvent
+--               -- [ () <$ Header._out_addPayment header
+--               -- ]
+--           }
+--
+--       pure ()
+--
+--   return ()
+--
+-- -- debounceSearchName
+-- --   :: forall t m. MonadWidget t m
+-- --   => Dynamic t Text
+-- --   -> m (Event t Text, Dynamic t Text)
+-- -- debounceSearchName searchName = do
+-- --   event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
+-- --   dynamic <- R.holdDyn "" event
+-- --   return (event, dynamic)
+--
+-- reducePayments
+--   :: forall t m. MonadWidget t m
+--   => [Payment]
+--   -> Event t Payment -- add payment
+--   -> Event t Payment -- edit payment
+--   -> Event t Payment -- delete payment
+--   -> m (Dynamic t [Payment])
+-- reducePayments initPayments addPayment editPayment deletePayment =
+--   R.foldDyn id initPayments $ R.leftmost
+--     [ (:) <$> addPayment
+--     , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
+--     , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
+--     ]
+--
+-- reducePaymentCategories
+--   :: forall t m. MonadWidget t m
+--   => [PaymentCategory]
+--   -> Dynamic t [Payment]      -- payments
+--   -> Event t PaymentCategory  -- add payment category
+--   -> Event t PaymentCategory  -- edit payment category
+--   -> Event t Payment          -- delete payment
+--   -> m (Dynamic t [PaymentCategory])
+-- reducePaymentCategories
+--   initPaymentCategories
+--   payments
+--   addPaymentCategory
+--   editPaymentCategory
+--   deletePayment
+--     =
+--   R.foldDyn id initPaymentCategories $ R.leftmost
+--     [ (:) <$> addPaymentCategory
+--     , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
+--     , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
+--     ]
+--   where
+--     deletePaymentName =
+--       R.attachWithMaybe
+--         (\ps p ->
+--           if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
+--             Nothing
+--           else
+--             Just (_payment_name p))
+--         (R.current payments)
+--         deletePayment
+--     lowerName = T.toLower . _payment_name
+--
+-- -- getSearchPayments
+-- --   :: forall t. Reflex t
+-- --   => Dynamic t Text
+-- --   -> Dynamic t Frequency
+-- --   -> Dynamic t [Payment]
+-- --   -> Dynamic t [Payment]
+-- -- getSearchPayments name frequency payments = do
+-- --   n <- name
+-- --   f <- frequency
+-- --   ps <- payments
+-- --   pure $ flip filter ps (\p ->
+-- --     (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
+-- --     && (_payment_frequency p == f)
+-- --     ))
diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
new file mode 100644
index 0000000..0c70f8a
--- /dev/null
+++ b/client/src/View/Payment/Reducer.hs
@@ -0,0 +1,66 @@
+module View.Payment.Reducer
+  ( perPage
+  , reducer
+  , In(..)
+  ) where
+
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (PaymentPage)
+
+import           Loadable     (Loadable (..))
+import qualified Loadable     as Loadable
+import qualified Util.Ajax    as AjaxUtil
+
+perPage :: Int
+perPage = 7
+
+data In t a b c = In
+  { _in_newPage       :: Event t Int
+  , _in_currentPage   :: Dynamic t Int
+  , _in_addPayment    :: Event t a
+  , _in_editPayment   :: Event t b
+  , _in_deletePayment :: Event t c
+  }
+
+data Action
+  = LoadPage Int
+  | GetResult (Either Text PaymentPage)
+
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
+reducer input = do
+
+  postBuild <- R.getPostBuild
+
+  let loadPage =
+        R.leftmost
+          [ 1 <$ postBuild
+          , _in_newPage input
+          , 1 <$ _in_addPayment input
+          , R.tag (R.current $ _in_currentPage input) (_in_editPayment input)
+          , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input)
+          ]
+
+  getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+
+  R.foldDyn
+    (\action _ -> case action of
+      LoadPage _                 -> Loading
+      GetResult (Left err)       -> Error err
+      GetResult (Right payments) -> Loaded payments
+    )
+    Loading
+    (R.leftmost
+      [ LoadPage <$> loadPage
+      , GetResult <$> getResult
+      ])
+
+  where
+    pageUrl p =
+      "api/payments?page="
+      <> (T.pack . show $ p)
+      <> "&perPage="
+      <> (T.pack . show $ perPage)
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 0793836..dde5168 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -4,209 +4,146 @@ module View.Payment.Table
   , Out(..)
   ) where
 
-import qualified Data.List           as L
-import qualified Data.Map            as M
-import qualified Data.Maybe          as Maybe
-import           Data.Text           (Text)
-import qualified Data.Text           as T
-import           Prelude             hiding (init)
-import           Reflex.Dom          (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom          as R
-
-import           Common.Model        (Category (..), Currency,
-                                      Frequency (Punctual), Payment (..),
-                                      PaymentCategory (..), SavedPayment,
-                                      User (..), UserId)
-import qualified Common.Model        as CM
-import qualified Common.Msg          as Msg
-import qualified Common.View.Format  as Format
-import qualified Component.Button    as Button
-import qualified Component.Modal     as Modal
-import qualified View.Payment.Clone  as Clone
-import qualified View.Payment.Delete as Delete
-import qualified View.Payment.Edit   as Edit
-import           View.Payment.Init   (Init (..))
-
-import qualified Util.Reflex         as ReflexUtil
-import qualified View.Icon           as Icon
+import qualified Data.List               as L
+import qualified Data.Map                as M
+import qualified Data.Maybe              as Maybe
+import           Data.Text               (Text)
+import qualified Data.Text               as T
+import           Reflex.Dom              (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom              as R
+
+import           Common.Model            (Category (..), Currency, Payment (..),
+                                          PaymentCategory (..), SavedPayment,
+                                          User (..), UserId)
+import qualified Common.Model            as CM
+import qualified Common.Msg              as Msg
+import qualified Common.View.Format      as Format
+
+import qualified Component.ConfirmDialog as ConfirmDialog
+import qualified Component.Table         as Table
+import qualified Util.Ajax               as Ajax
+import qualified Util.Either             as EitherUtil
+import qualified View.Payment.Form       as Form
 
 data In t = In
-  { _in_init              :: Init
-  , _in_currency          :: Currency
+  { _in_users             :: [User]
   , _in_currentUser       :: UserId
-  , _in_currentPage       :: Dynamic t Int
-  , _in_payments          :: Dynamic t [Payment]
-  , _in_perPage           :: Int
-  , _in_paymentCategories :: Dynamic t [PaymentCategory]
   , _in_categories        :: [Category]
+  , _in_currency          :: Currency
+  , _in_payments          :: [Payment]
+  , _in_paymentCategories :: [PaymentCategory]
   }
 
 data Out t = Out
-  { _out_addPayment    :: Event t SavedPayment
-  , _out_editPayment   :: Event t SavedPayment
-  , _out_deletePayment :: Event t Payment
+  { _out_add    :: Event t SavedPayment
+  , _out_edit   :: Event t SavedPayment
+  , _out_delete :: Event t Payment
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
 view input = do
-  R.divClass "table" $ do
-
-    (addPayment, editPayment, deletePayment) <- R.divClass "lines" $ do
-      R.divClass "header" $ do
-        R.divClass "cell name" $ R.text $ Msg.get Msg.Payment_Name
-        R.divClass "cell cost" $ R.text $ Msg.get Msg.Payment_Cost
-        R.divClass "cell user" $ R.text $ Msg.get Msg.Payment_User
-        R.divClass "cell category" $ R.text $ Msg.get Msg.Payment_Category
-        R.divClass "cell date" $ R.text $ Msg.get Msg.Payment_Date
-        R.divClass "cell" $ R.blank
-        R.divClass "cell" $ R.blank
-        R.divClass "cell" $ R.blank
-
-      result <-
-        (R.simpleList paymentRange (paymentRow init currency currentUser paymentCategories))
-
-      return $
-        ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
-        , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
-        , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
-        )
-
-    ReflexUtil.divClassVisibleIf (null <$> payments) "emptyTableMsg" $
-      R.text $ Msg.get Msg.Payment_Empty
-
-    return $ Out
-      { _out_addPayment = addPayment
-      , _out_editPayment = editPayment
-      , _out_deletePayment = deletePayment
-      }
-
-  where
-    init = _in_init input
-    currency = _in_currency input
-    currentUser = _in_currentUser input
-    currentPage = _in_currentPage input
-    payments = _in_payments input
-    paymentRange = getPaymentRange (_in_perPage input) <$> payments <*> currentPage
-    paymentCategories = _in_paymentCategories input
-
-getPaymentRange :: Int -> [Payment] -> Int -> [Payment]
-getPaymentRange perPage payments currentPage =
-  take perPage
-    . drop ((currentPage - 1) * perPage)
-    . reverse
-    . L.sortOn _payment_date
-    $ payments
-
-paymentRow
-  :: forall t m. MonadWidget t m
-  => Init
-  -> Currency
-  -> UserId
-  -> Dynamic t [PaymentCategory]
-  -> Dynamic t Payment
-  -> m (Event t SavedPayment, Event t SavedPayment, Event t Payment)
-paymentRow init currency currentUser paymentCategories payment =
-  R.divClass "row" $ do
-
-    R.divClass "cell name" $
-      R.dynText $ fmap _payment_name payment
-
-    R.divClass "cell cost" $
-      R.dynText $ fmap (Format.price currency . _payment_cost) payment
-
-    let user = R.ffor payment (\p ->
-          CM.findUser (_payment_user p) (_init_users init))
-
-    R.divClass "cell user" $
-      R.dynText $ flip fmap user $ \mbUser -> case mbUser of
-        Just u -> _user_name u
-        _      -> ""
-
-    let category = do
-          p <- payment
-          pcs <- paymentCategories
-          return $ findCategory (_init_categories init) pcs (_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 $ R.ffor category $ \case
-          Just c -> _category_name c
-          _      -> ""
-
-    R.divClass "cell date" $ do
-      R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment
-      R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment
-
-    let categoryId = (Maybe.fromMaybe (-1) . fmap _category_id) <$> category
-
-    clonePayment <-
-      R.divClass "cell button" $
-        Button._out_clic <$> (Button.view $
-          Button.defaultIn Icon.clone)
-
-    paymentCloned <-
-      Modal.view $ Modal.In
-        { Modal._in_show    = clonePayment
-        , Modal._in_content =
-            Clone.view $ Clone.In
-              { Clone._in_show = clonePayment
-              , Clone._in_categories = _init_categories init
-              , Clone._in_paymentCategories = paymentCategories
-              , Clone._in_payment = payment
-              , Clone._in_category = categoryId
-              }
-        }
 
-    let isFromCurrentUser =
-          R.ffor
-            payment
-            (\p -> _payment_user p == currentUser)
-
-    editPayment <-
-      R.divClass "cell button" $
-        ReflexUtil.divVisibleIf isFromCurrentUser $
-          Button._out_clic <$> (Button.view $
-            Button.defaultIn Icon.edit)
-
-    paymentEdited <-
-      Modal.view $ Modal.In
-        { Modal._in_show    = editPayment
-        , Modal._in_content =
-            Edit.view $ Edit.In
-              { Edit._in_show = editPayment
-              , Edit._in_categories = _init_categories init
-              , Edit._in_paymentCategories = paymentCategories
-              , Edit._in_payment = payment
-              , Edit._in_category = categoryId
-              }
+  table <- Table.view $ Table.In
+    { Table._in_headerLabel = headerLabel
+    , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input
+    , Table._in_cell =
+      cell
+        (_in_users input)
+        (_in_categories input)
+        (_in_paymentCategories input)
+        (_in_currency input)
+    , Table._in_cloneModal = \payment ->
+      Form.view $ Form.In
+        { Form._in_categories = _in_categories input
+        , Form._in_paymentCategories = _in_paymentCategories input
+        , Form._in_operation = Form.Clone payment
         }
-
-    deletePayment <-
-      R.divClass "cell button" $
-        ReflexUtil.divVisibleIf isFromCurrentUser $
-          Button._out_clic <$> (Button.view $
-            (Button.defaultIn Icon.delete)
-              { Button._in_class = R.constDyn "deletePayment"
-              })
-
-    paymentDeleted <-
-      Modal.view $ Modal.In
-        { Modal._in_show    = deletePayment
-        , Modal._in_content =
-            Delete.view $ Delete.In
-              { Delete._in_payment = payment
-              }
+    , Table._in_editModal = \payment ->
+      Form.view $ Form.In
+        { Form._in_categories = _in_categories input
+        , Form._in_paymentCategories = _in_paymentCategories input
+        , Form._in_operation = Form.Edit payment
         }
-
-    return $ (paymentCloned, paymentEdited, paymentDeleted)
+    , Table._in_deleteModal = \payment ->
+      ConfirmDialog.view $ ConfirmDialog.In
+        { ConfirmDialog._in_header  = Msg.get Msg.Payment_DeleteConfirm
+        , ConfirmDialog._in_confirm = \e -> do
+          res <- Ajax.delete
+            (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment])
+            e
+          return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+        }
+    , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user
+    }
+
+  return $ Out
+    { _out_add = Table._out_add table
+    , _out_edit = Table._out_edit table
+    , _out_delete = Table._out_delete table
+    }
+
+data Header
+  = NameHeader
+  | CostHeader
+  | UserHeader
+  | CategoryHeader
+  | DateHeader
+  deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel NameHeader     = Msg.get Msg.Payment_Name
+headerLabel CostHeader     = Msg.get Msg.Payment_Cost
+headerLabel UserHeader     = Msg.get Msg.Payment_User
+headerLabel CategoryHeader = Msg.get Msg.Payment_Category
+headerLabel DateHeader     = Msg.get Msg.Payment_Date
+
+cell
+  :: forall t m. MonadWidget t m
+  => [User]
+  -> [Category]
+  -> [PaymentCategory]
+  -> Currency
+  -> Header
+  -> Payment
+  -> m ()
+cell users categories paymentCategories currency header payment =
+  case header of
+    NameHeader ->
+      R.text $ _payment_name payment
+
+    CostHeader ->
+      R.text . Format.price currency . _payment_cost $ payment
+
+    UserHeader ->
+      R.text . Maybe.fromMaybe "" . fmap _user_name $ CM.findUser (_payment_user payment) users
+
+    CategoryHeader ->
+      let
+        category =
+          findCategory categories paymentCategories (_payment_name payment)
+
+        attrs =
+          case category of
+            Just c ->
+              M.fromList
+                [ ("class", "tag")
+                , ("style", T.concat [ "background-color: ", _category_color c ])
+                ]
+
+            Nothing ->
+              M.singleton "display" "none"
+      in
+        R.elAttr "span" attrs $
+          R.text $
+            Maybe.fromMaybe "" (_category_name <$> category)
+
+    DateHeader ->
+      do
+        R.elClass "span" "shortDate" $
+          R.text . Format.shortDay . _payment_date $ payment
+
+        R.elClass "span" "longDate" $
+          R.text . Format.longDay . _payment_date $ payment
 
 findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
 findCategory categories paymentCategories paymentName = do
-- 
cgit v1.2.3


From 4dc84dbda7ba3ea60d13e6f81eeec556974b7c72 Mon Sep 17 00:00:00 2001
From: Joris
Date: Thu, 7 Nov 2019 07:59:41 +0100
Subject: Show payment header infos

---
 client/src/View/Payment/Header.hs      | 187 ---------------------------------
 client/src/View/Payment/HeaderForm.hs  |  78 ++++++++++++++
 client/src/View/Payment/HeaderInfos.hs |  96 +++++++++++++++++
 client/src/View/Payment/Init.hs        |  13 ---
 client/src/View/Payment/Payment.hs     |  53 ++++++----
 5 files changed, 204 insertions(+), 223 deletions(-)
 delete mode 100644 client/src/View/Payment/Header.hs
 create mode 100644 client/src/View/Payment/HeaderForm.hs
 create mode 100644 client/src/View/Payment/HeaderInfos.hs
 delete mode 100644 client/src/View/Payment/Init.hs

(limited to 'client/src')

diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs
deleted file mode 100644
index c8ca347..0000000
--- a/client/src/View/Payment/Header.hs
+++ /dev/null
@@ -1,187 +0,0 @@
-module View.Payment.Header
-  ( view
-  , In(..)
-  , Out(..)
-  ) where
-
-import           Control.Monad          (forM_)
-import           Control.Monad.IO.Class (liftIO)
-import qualified Data.List              as L hiding (groupBy)
-import qualified Data.Map               as M
-import           Data.Maybe             (fromMaybe)
-import           Data.Text              (Text)
-import qualified Data.Text              as T
-import           Data.Time              (NominalDiffTime)
-import qualified Data.Time              as Time
-import qualified Data.Validation        as V
-import           Prelude                hiding (init)
-import           Reflex.Dom             (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Category, Currency,
-                                         ExceedingPayer (..), Frequency (..),
-                                         Income (..), Payment (..),
-                                         PaymentCategory, SavedPayment (..),
-                                         User (..))
-import qualified Common.Model           as CM
-import qualified Common.Msg             as Msg
-import qualified Common.View.Format     as Format
-
-import qualified Component.Button       as Button
-import qualified Component.Input        as Input
-import qualified Component.Modal        as Modal
-import qualified Component.Select       as Select
-import qualified Util.List              as L
-import qualified View.Payment.Form      as Form
-import           View.Payment.Init      (Init (..))
-
-data In t = In
-  { _in_init              :: Init
-  , _in_currency          :: Currency
-  , _in_payments          :: Dynamic t [Payment]
-  , _in_searchPayments    :: Dynamic t [Payment]
-  , _in_paymentCategories :: Dynamic t [PaymentCategory]
-  }
-
-data Out t = Out
-  { _out_searchName      :: Dynamic t Text
-  , _out_searchFrequency :: Dynamic t Frequency
-  , _out_addPayment      :: Event t SavedPayment
-  }
-
-view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input =
-  R.divClass "header" $ do
-    rec
-      addPayment <-
-        payerAndAdd
-          incomes
-          payments
-          users
-          categories
-          paymentCategories
-          currency
-          searchFrequency
-      let resetSearchName = fmap (const ()) $ addPayment
-      (searchName, searchFrequency)  <- searchLine resetSearchName
-
-      infos (_in_searchPayments input) users currency
-
-    return $ Out
-      { _out_searchName = searchName
-      , _out_searchFrequency = searchFrequency
-      , _out_addPayment = addPayment
-      }
-  where
-    init = _in_init input
-    incomes = _init_incomes init
-    initPayments = _init_payments init
-    payments = _in_payments input
-    users = _init_users init
-    categories = _init_categories init
-    currency = _in_currency input
-    paymentCategories = _in_paymentCategories input
-
-payerAndAdd
-  :: forall t m. MonadWidget t m
-  => [Income]
-  -> Dynamic t [Payment]
-  -> [User]
-  -> [Category]
-  -> Dynamic t [PaymentCategory]
-  -> Currency
-  -> Dynamic t Frequency
-  -> m (Event t SavedPayment)
-payerAndAdd incomes payments users categories paymentCategories currency frequency = do
-  time <- liftIO Time.getCurrentTime
-  R.divClass "payerAndAdd" $ do
-
-    let exceedingPayers =
-          R.ffor payments $ \ps ->
-            CM.getExceedingPayers time users incomes $
-              filter ((==) Punctual . _payment_frequency) ps
-
-    R.divClass "exceedingPayers" $
-      R.simpleList exceedingPayers $ \exceedingPayer ->
-        R.elClass "span" "exceedingPayer" $ do
-          R.elClass "span" "userName" $
-            R.dynText . R.ffor exceedingPayer $ \ep ->
-              fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId ep) users
-          R.elClass "span" "amount" $ do
-            R.text "+ "
-            R.dynText . R.ffor exceedingPayer $ \ep ->
-              Format.price currency $ _exceedingPayer_amount ep
-
-    addPayment <- Button._out_clic <$>
-      (Button.view $
-        (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
-          { Button._in_class = R.constDyn "addPayment"
-          })
-
-    Modal.view $ Modal.In
-      { Modal._in_show    = addPayment
-      , Modal._in_content = \_ -> return (R.never, R.never) -- TODO
-      }
-
-searchLine
-  :: forall t m. MonadWidget t m
-  => Event t ()
-  -> m (Dynamic t Text, Dynamic t Frequency)
-searchLine reset = do
-  R.divClass "searchLine" $ do
-    searchName <- Input._out_raw <$> (Input.view
-      ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
-      ("" <$ reset)
-      R.never)
-
-    let frequencies = M.fromList
-          [ (Punctual, Msg.get Msg.Payment_PunctualMale)
-          , (Monthly, Msg.get Msg.Payment_MonthlyMale)
-          ]
-
-    searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
-        { Select._in_label        = ""
-        , Select._in_initialValue = Punctual
-        , Select._in_value        = R.never
-        , Select._in_values       = R.constDyn frequencies
-        , Select._in_reset        = R.never
-        , Select._in_isValid      = V.Success
-        , Select._in_validate     = R.never
-        })
-
-    return (searchName, searchFrequency)
-
-infos
-  :: forall t m. MonadWidget t m
-  => Dynamic t [Payment]
-  -> [User]
-  -> Currency -> m ()
-infos payments users currency =
-  R.divClass "infos" $ do
-
-    R.elClass "span" "total" $ do
-      R.dynText $ do
-        ps <- payments
-        let paymentCount = length ps
-            total = sum . map _payment_cost $ ps
-        pure . Msg.get $ Msg.Payment_Worth
-          (T.intercalate " "
-            [ (Format.number paymentCount)
-            , if paymentCount > 1
-                then Msg.get Msg.Payment_Many
-                else Msg.get Msg.Payment_One
-            ])
-          (Format.price currency total)
-
-    R.elClass "span" "partition" . R.dynText $ do
-      ps <- payments
-      let totalByUser =
-            L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
-              . map (\(u, xs) -> (u, sum . map snd $ xs))
-              . L.groupBy fst
-              . map (\p -> (_payment_user p, _payment_cost p))
-              $ ps
-      pure . T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
-        Msg.get $ Msg.Payment_By
-          (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
-          (Format.price currency userTotal)
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
new file mode 100644
index 0000000..07a6b81
--- /dev/null
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -0,0 +1,78 @@
+module View.Payment.HeaderForm
+  ( view
+  ) where
+
+import qualified Data.Map          as M
+import           Data.Text         (Text)
+import qualified Data.Validation   as V
+import           Reflex.Dom        (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom        as R
+
+import           Common.Model      (Category, Currency, ExceedingPayer (..),
+                                    Frequency (..), Income (..), Payment (..),
+                                    PaymentCategory, SavedPayment (..),
+                                    User (..))
+import qualified Common.Msg        as Msg
+
+import qualified Component.Button  as Button
+import qualified Component.Input   as Input
+import qualified Component.Modal   as Modal
+import qualified Component.Select  as Select
+import qualified View.Payment.Form as Form
+
+data In t = In
+  { _in_reset             :: Event t ()
+  , _in_categories        :: [Category]
+  , _in_paymentCategories :: [PaymentCategory]
+  }
+
+data Out = Out
+  { _out_name       :: Event t Text
+  , _out_frequency  :: Event t Frequency
+  , _out_addPayment :: Event t SavedPayment
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
+  R.divClass "g-HeaderForm" $ do
+    searchName <- Input._out_raw <$> (Input.view
+      ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
+      ("" <$ _in_reset input)
+      R.never)
+
+    let frequencies = M.fromList
+          [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+          , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+          ]
+
+    searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
+        { Select._in_label        = ""
+        , Select._in_initialValue = Punctual
+        , Select._in_value        = R.never
+        , Select._in_values       = R.constDyn frequencies
+        , Select._in_reset        = R.never
+        , Select._in_isValid      = V.Success
+        , Select._in_validate     = R.never
+        })
+
+    addPaymentButton <- Button._out_clic <$>
+      (Button.view $
+        (Button.defaultIn (R.text $ Msg.get Msg.Payment_Add))
+          { Button._in_class = R.constDyn "addPayment"
+          })
+
+    addPayment <- Modal.view $ Modal.In
+      { Modal._in_show    = addPaymentButton
+      , Modal._in_content =
+        Form.view $ Form.In
+          { Form._in_categories = _in_categories input
+          , Form._in_paymentCategories = _in_paymentCategories input
+          , Form._in_operation = Form.New searchFrequency
+          }
+      }
+
+    return $ Out
+      { _out_name = searchName
+      , _out_frequency = searchFrequency
+      , _out_addPayment = addPayment
+      }
diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs
new file mode 100644
index 0000000..12facc4
--- /dev/null
+++ b/client/src/View/Payment/HeaderInfos.hs
@@ -0,0 +1,96 @@
+module View.Payment.HeaderInfos
+  ( view
+  , In(..)
+  ) where
+
+import           Control.Monad.IO.Class (liftIO)
+import qualified Data.List              as L hiding (groupBy)
+import           Data.Map               (Map)
+import qualified Data.Map               as M
+import           Data.Maybe             (fromMaybe)
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import qualified Data.Time              as Time
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Currency, ExceedingPayer (..),
+                                         Payment (..), PaymentHeader (..),
+                                         SavedPayment (..), User (..), UserId)
+import qualified Common.Model           as CM
+import qualified Common.Msg             as Msg
+import qualified Common.View.Format     as Format
+
+import qualified Util.List              as L
+
+data In t = In
+  { _in_users        :: [User]
+  , _in_currency     :: Currency
+  , _in_header       :: PaymentHeader
+  , _in_paymentCount :: Int
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input =
+  R.divClass "g-HeaderInfos" $ do
+      exceedingPayers
+        (_in_users input)
+        (_in_currency input)
+        (_paymentHeader_exceedingPayers header)
+
+      infos
+        (_in_users input)
+        (_in_currency input)
+        (_paymentHeader_repartition header)
+        (_in_paymentCount input)
+
+  where
+    header = _in_header input
+
+exceedingPayers
+  :: forall t m. MonadWidget t m
+  => [User]
+  -> Currency
+  -> [ExceedingPayer]
+  -> m ()
+exceedingPayers users currency payers =
+  R.divClass "g-HeaderInfos__ExceedingPayers" $
+    flip mapM_ payers $ \payer ->
+      R.elClass "span" "exceedingPayer" $ do
+        R.elClass "span" "userName" $
+          R.text $
+            fromMaybe "" . fmap _user_name $ CM.findUser (_exceedingPayer_userId payer) users
+        R.elClass "span" "amount" $ do
+          R.text "+ "
+          R.text . Format.price currency $ _exceedingPayer_amount payer
+
+infos
+  :: forall t m. MonadWidget t m
+  => [User]
+  -> Currency
+  -> Map UserId Int
+  -> Int
+  -> m ()
+infos users currency repartition paymentCount =
+  R.divClass "g-HeaderInfos__Repartition" $ do
+
+    R.elClass "span" "total" $ do
+      R.text $
+        Msg.get $ Msg.Payment_Worth
+          (T.intercalate " "
+            [ (Format.number paymentCount)
+            , if paymentCount > 1
+                then Msg.get Msg.Payment_Many
+                else Msg.get Msg.Payment_One
+            ])
+          (Format.price currency (M.foldl (+) 0 repartition))
+
+    R.elClass "span" "partition" . R.text $
+      let totalByUser =
+            L.sortBy (\(_, t1) (_, t2) -> compare t2 t1)
+              . M.toList
+              $ repartition
+      in  T.intercalate ", " . flip map totalByUser $ \(userId, userTotal) ->
+            Msg.get $ Msg.Payment_By
+              (fromMaybe "" . fmap _user_name $ CM.findUser userId users)
+              (Format.price currency userTotal)
diff --git a/client/src/View/Payment/Init.hs b/client/src/View/Payment/Init.hs
deleted file mode 100644
index d9f85c8..0000000
--- a/client/src/View/Payment/Init.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module View.Payment.Init
-  ( Init(..)
-  ) where
-
-import           Common.Model (Category, Income, Payment, PaymentCategory, User)
-
-data Init = Init
-  { _init_users             :: [User]
-  , _init_payments          :: [Payment]
-  , _init_incomes           :: [Income]
-  , _init_categories        :: [Category]
-  , _init_paymentCategories :: [PaymentCategory]
-  } deriving (Show)
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index bf0186f..f47b627 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -3,29 +3,29 @@ module View.Payment.Payment
   , In(..)
   ) where
 
-import qualified Data.Maybe           as Maybe
-import           Data.Text            (Text)
-import qualified Data.Text            as T
-import           Data.Time.Clock      (NominalDiffTime)
-import           Prelude              hiding (init)
-import           Reflex.Dom           (Dynamic, Event, MonadWidget, Reflex)
-import qualified Reflex.Dom           as R
-
-import           Common.Model         (Currency, Frequency, Income (..),
-                                       Payment (..), PaymentCategory (..),
-                                       PaymentId, PaymentPage (..),
-                                       SavedPayment (..), User, UserId)
-import qualified Common.Util.Text     as T
-
-import qualified Component.Pages      as Pages
-import           Loadable             (Loadable (..))
+import qualified Data.Maybe               as Maybe
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Time.Clock          (NominalDiffTime)
+import           Prelude                  hiding (init)
+import           Reflex.Dom               (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom               as R
+
+import           Common.Model             (Currency, Frequency, Income (..),
+                                           Payment (..), PaymentCategory (..),
+                                           PaymentId, PaymentPage (..),
+                                           SavedPayment (..), User, UserId)
+import qualified Common.Util.Text         as T
+
+import qualified Component.Pages          as Pages
+import           Loadable                 (Loadable (..))
 import qualified Loadable
-import qualified Util.Ajax            as AjaxUtil
-import qualified Util.Reflex          as ReflexUtil
-import qualified View.Payment.Header  as Header
-import           View.Payment.Init    (Init (..))
-import qualified View.Payment.Reducer as Reducer
-import qualified View.Payment.Table   as Table
+import qualified Util.Ajax                as AjaxUtil
+import qualified Util.Reflex              as ReflexUtil
+import qualified View.Payment.HeaderInfos as HeaderInfos
+-- import qualified View.Payment.HeaderForm as HeaderForm
+import qualified View.Payment.Reducer     as Reducer
+import qualified View.Payment.Table       as Table
 
 data In t = In
   { _in_currentUser :: UserId
@@ -61,7 +61,14 @@ view input = do
       deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
       result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
-        flip Loadable.view is $ \(PaymentPage payments paymentCategories count) -> do
+        flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do
+          HeaderInfos.view $ HeaderInfos.In
+            { HeaderInfos._in_users = _in_users input
+            , HeaderInfos._in_currency = _in_currency input
+            , HeaderInfos._in_header = header
+            , HeaderInfos._in_paymentCount = count
+            }
+
           table <- Table.view $ Table.In
             { Table._in_users = _in_users input
             , Table._in_currentUser = _in_currentUser input
-- 
cgit v1.2.3


From c0ea63f8c1a8c7123b78798cec99726b113fb1f3 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 17 Nov 2019 18:08:28 +0100
Subject: Optimize and refactor payments

---
 client/src/Loadable.hs                 |   3 +-
 client/src/Util/Ajax.hs                |   5 +-
 client/src/Util/Either.hs              |   2 +-
 client/src/Util/List.hs                |  13 ---
 client/src/View/Payment/Form.hs        |  52 +++++-----
 client/src/View/Payment/HeaderForm.hs  |  69 +++++++------
 client/src/View/Payment/HeaderInfos.hs |  28 +++---
 client/src/View/Payment/Payment.hs     | 177 +++++----------------------------
 client/src/View/Payment/Reducer.hs     |  83 +++++++++++++---
 client/src/View/Payment/Table.hs       |  31 ++----
 10 files changed, 183 insertions(+), 280 deletions(-)
 delete mode 100644 client/src/Util/List.hs

(limited to 'client/src')

diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index f57b99c..2b9008a 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -16,6 +16,7 @@ data Loadable t
   = Loading
   | Error Text
   | Loaded t
+  deriving Show
 
 instance Functor Loadable where
   fmap f Loading    = Loading
@@ -46,6 +47,6 @@ fromEvent =
     Loading
 
 view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
-view _ (Loading)  = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
+view _ Loading  = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
 view _ (Error e)  = R.text e >> return Nothing
 view f (Loaded x) = Just <$> f x
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index 47f4f3c..dc56701 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -16,6 +16,7 @@ import qualified Data.Map.Lazy        as LM
 import           Data.Text            (Text)
 import qualified Data.Text            as T
 import qualified Data.Text.Encoding   as T
+import           Data.Time.Clock      (NominalDiffTime)
 import           Reflex.Dom           (Dynamic, Event, IsXhrPayload,
                                        MonadWidget, XhrRequest,
                                        XhrRequestConfig (..), XhrResponse,
@@ -28,7 +29,9 @@ import qualified Loadable
 getNow :: forall t m a. (MonadWidget t m, FromJSON a) => Text -> m (Dynamic t (Loadable a))
 getNow url = do
   postBuild <- R.getPostBuild
-  get (R.tag (R.constant url) postBuild) >>= Loadable.fromEvent
+  get (url <$ postBuild)
+    >>= R.debounce (0 :: NominalDiffTime) -- Fired 2 times otherwise
+    >>= Loadable.fromEvent
 
 get
   :: forall t m a. (MonadWidget t m, FromJSON a)
diff --git a/client/src/Util/Either.hs b/client/src/Util/Either.hs
index 2910d95..e76bc8a 100644
--- a/client/src/Util/Either.hs
+++ b/client/src/Util/Either.hs
@@ -2,6 +2,6 @@ module Util.Either
   ( eitherToMaybe
   ) where
 
-eitherToMaybe :: Either a b -> Maybe b
+eitherToMaybe :: forall a b. Either a b -> Maybe b
 eitherToMaybe (Right b) = Just b
 eitherToMaybe _         = Nothing
diff --git a/client/src/Util/List.hs b/client/src/Util/List.hs
deleted file mode 100644
index 4e22ba8..0000000
--- a/client/src/Util/List.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module Util.List
-  ( groupBy
-  ) where
-
-import           Control.Arrow ((&&&))
-import           Data.Function (on)
-import qualified Data.List     as L
-
-groupBy :: forall a b. (Ord b) => (a -> b) -> [a] -> [(b, [a])]
-groupBy f =
-  map (f . head &&& id)
-    . L.groupBy ((==) `on` f)
-    . L.sortBy (compare `on` f)
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 99b0848..6c3c1e8 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -4,6 +4,7 @@ module View.Payment.Form
   , Operation(..)
   ) where
 
+import           Control.Monad             (join)
 import           Control.Monad.IO.Class    (liftIO)
 import           Data.Aeson                (Value)
 import qualified Data.Aeson                as Aeson
@@ -13,6 +14,7 @@ import qualified Data.Map                  as M
 import qualified Data.Maybe                as Maybe
 import           Data.Text                 (Text)
 import qualified Data.Text                 as T
+import           Data.Time                 (NominalDiffTime)
 import           Data.Time.Calendar        (Day)
 import qualified Data.Time.Calendar        as Calendar
 import qualified Data.Time.Clock           as Clock
@@ -25,9 +27,7 @@ import qualified Text.Read                 as T
 import           Common.Model              (Category (..), CategoryId,
                                             CreatePaymentForm (..),
                                             EditPaymentForm (..),
-                                            Frequency (..), Payment (..),
-                                            PaymentCategory (..),
-                                            SavedPayment (..))
+                                            Frequency (..), Payment (..))
 import qualified Common.Msg                as Msg
 import qualified Common.Util.Time          as TimeUtil
 import qualified Common.Validation.Payment as PaymentValidation
@@ -37,20 +37,20 @@ import qualified Component.Modal           as Modal
 import qualified Component.ModalForm       as ModalForm
 import qualified Component.Select          as Select
 import qualified Util.Ajax                 as Ajax
+import qualified Util.Either               as EitherUtil
 import qualified Util.Validation           as ValidationUtil
 
-data In = In
-  { _in_categories        :: [Category]
-  , _in_paymentCategories :: [PaymentCategory]
-  , _in_operation         :: Operation
+data In t = In
+  { _in_categories :: [Category]
+  , _in_operation  :: Operation t
   }
 
-data Operation
-  = New Frequency
+data Operation t
+  = New (Dynamic t Frequency)
   | Clone Payment
   | Edit Payment
 
-view :: forall t m a. MonadWidget t m => In -> Modal.Content t m SavedPayment
+view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment
 view input cancel = do
   rec
     let reset = R.leftmost
@@ -105,9 +105,10 @@ view input cancel = do
         (d <$ reset)
         confirm)
 
-      let setCategory =
-            R.fmapMaybe id . R.updated $
-              R.ffor (Input._out_raw name) findCategory
+      setCategory <-
+        R.debounce  (1 :: NominalDiffTime) (R.updated $ Input._out_raw name)
+          >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>)))
+          >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe))
 
       category <- Select._out_value <$> (Select.view $ Select.In
         { Select._in_label = Msg.get Msg.Payment_Category
@@ -124,12 +125,13 @@ view input cancel = do
         c <- cost
         d <- date
         cat <- category
+        f <- frequency
         return (mkPayload
           <$> ValidationUtil.nelError n
           <*> V.Success c
           <*> V.Success d
           <*> ValidationUtil.nelError cat
-          <*> V.Success frequency)
+          <*> V.Success f)
 
     frequencies =
       M.fromList
@@ -140,6 +142,12 @@ view input cancel = do
     categories = M.fromList . flip map (_in_categories input) $ \c ->
       (_category_id c, _category_name c)
 
+    category =
+      case op of
+        New _   -> -1
+        Clone p -> _payment_category p
+        Edit p  -> _payment_category p
+
     op = _in_operation input
 
     name =
@@ -162,17 +170,11 @@ view input cancel = do
           Clone p -> currentDay
           Edit p  -> _payment_date p
 
-    category =
-      case op of
-        New _   -> -1
-        Clone p -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
-        Edit p  -> Maybe.fromMaybe (-1) $ findCategory (_payment_name p)
-
     frequency =
       case op of
         New f   -> f
-        Clone p -> _payment_frequency p
-        Edit p  -> _payment_frequency p
+        Clone p -> R.constDyn $ _payment_frequency p
+        Edit p  -> R.constDyn $ _payment_frequency p
 
     headerLabel =
       case op of
@@ -189,9 +191,3 @@ view input cancel = do
       case op of
         Edit p -> \a b c d e -> Aeson.toJSON $ EditPaymentForm (_payment_id p) a b c d e
         _      -> \a b c d e -> Aeson.toJSON $ CreatePaymentForm a b c d e
-
-    findCategory :: Text -> Maybe CategoryId
-    findCategory paymentName =
-      fmap _paymentCategory_category
-        . L.find ((==) (T.toLower paymentName) . _paymentCategory_name)
-        $ (_in_paymentCategories input)
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
index 07a6b81..c8ca4d9 100644
--- a/client/src/View/Payment/HeaderForm.hs
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -1,5 +1,7 @@
 module View.Payment.HeaderForm
   ( view
+  , In(..)
+  , Out(..)
   ) where
 
 import qualified Data.Map          as M
@@ -8,10 +10,8 @@ import qualified Data.Validation   as V
 import           Reflex.Dom        (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom        as R
 
-import           Common.Model      (Category, Currency, ExceedingPayer (..),
-                                    Frequency (..), Income (..), Payment (..),
-                                    PaymentCategory, SavedPayment (..),
-                                    User (..))
+import           Common.Model      (Category, Currency, Frequency (..),
+                                    Income (..), Payment (..), User (..))
 import qualified Common.Msg        as Msg
 
 import qualified Component.Button  as Button
@@ -21,39 +21,43 @@ import qualified Component.Select  as Select
 import qualified View.Payment.Form as Form
 
 data In t = In
-  { _in_reset             :: Event t ()
-  , _in_categories        :: [Category]
-  , _in_paymentCategories :: [PaymentCategory]
+  { _in_reset      :: Event t ()
+  , _in_categories :: [Category]
   }
 
-data Out = Out
-  { _out_name       :: Event t Text
+data Out t = Out
+  { _out_search     :: Event t Text
   , _out_frequency  :: Event t Frequency
-  , _out_addPayment :: Event t SavedPayment
+  , _out_addPayment :: Event t Payment
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
-view input = do
-  R.divClass "g-HeaderForm" $ do
-    searchName <- Input._out_raw <$> (Input.view
-      ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
-      ("" <$ _in_reset input)
-      R.never)
+view input =
+  R.divClass "g-PaymentHeaderForm" $ do
 
-    let frequencies = M.fromList
-          [ (Punctual, Msg.get Msg.Payment_PunctualMale)
-          , (Monthly, Msg.get Msg.Payment_MonthlyMale)
-          ]
+    (searchName, frequency) <- R.el "div" $ do
 
-    searchFrequency <- Select._out_raw <$> (Select.view $ Select.In
-        { Select._in_label        = ""
-        , Select._in_initialValue = Punctual
-        , Select._in_value        = R.never
-        , Select._in_values       = R.constDyn frequencies
-        , Select._in_reset        = R.never
-        , Select._in_isValid      = V.Success
-        , Select._in_validate     = R.never
-        })
+      searchName <- Input._out_raw <$> (Input.view
+        ( Input.defaultIn { Input._in_label = Msg.get Msg.Search_Name })
+        ("" <$ _in_reset input)
+        R.never)
+
+      let frequencies = M.fromList
+            [ (Punctual, Msg.get Msg.Payment_PunctualMale)
+            , (Monthly, Msg.get Msg.Payment_MonthlyMale)
+            ]
+
+      frequency <- Select._out_raw <$> (Select.view $ Select.In
+          { Select._in_label        = ""
+          , Select._in_initialValue = Punctual
+          , Select._in_value        = R.never
+          , Select._in_values       = R.constDyn frequencies
+          , Select._in_reset        = R.never
+          , Select._in_isValid      = V.Success
+          , Select._in_validate     = R.never
+          })
+
+      return (searchName, frequency)
 
     addPaymentButton <- Button._out_clic <$>
       (Button.view $
@@ -66,13 +70,12 @@ view input = do
       , Modal._in_content =
         Form.view $ Form.In
           { Form._in_categories = _in_categories input
-          , Form._in_paymentCategories = _in_paymentCategories input
-          , Form._in_operation = Form.New searchFrequency
+          , Form._in_operation = Form.New frequency
           }
       }
 
     return $ Out
-      { _out_name = searchName
-      , _out_frequency = searchFrequency
+      { _out_search = R.updated searchName
+      , _out_frequency = R.updated frequency
       , _out_addPayment = addPayment
       }
diff --git a/client/src/View/Payment/HeaderInfos.hs b/client/src/View/Payment/HeaderInfos.hs
index 12facc4..f84ee1f 100644
--- a/client/src/View/Payment/HeaderInfos.hs
+++ b/client/src/View/Payment/HeaderInfos.hs
@@ -16,13 +16,11 @@ import qualified Reflex.Dom             as R
 
 import           Common.Model           (Currency, ExceedingPayer (..),
                                          Payment (..), PaymentHeader (..),
-                                         SavedPayment (..), User (..), UserId)
+                                         User (..), UserId)
 import qualified Common.Model           as CM
 import qualified Common.Msg             as Msg
 import qualified Common.View.Format     as Format
 
-import qualified Util.List              as L
-
 data In t = In
   { _in_users        :: [User]
   , _in_currency     :: Currency
@@ -32,17 +30,17 @@ data In t = In
 
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input =
-  R.divClass "g-HeaderInfos" $ do
-      exceedingPayers
-        (_in_users input)
-        (_in_currency input)
-        (_paymentHeader_exceedingPayers header)
+  R.divClass "g-PaymentHeaderInfos" $ do
+    exceedingPayers
+      (_in_users input)
+      (_in_currency input)
+      (_paymentHeader_exceedingPayers header)
 
-      infos
-        (_in_users input)
-        (_in_currency input)
-        (_paymentHeader_repartition header)
-        (_in_paymentCount input)
+    infos
+      (_in_users input)
+      (_in_currency input)
+      (_paymentHeader_repartition header)
+      (_in_paymentCount input)
 
   where
     header = _in_header input
@@ -54,7 +52,7 @@ exceedingPayers
   -> [ExceedingPayer]
   -> m ()
 exceedingPayers users currency payers =
-  R.divClass "g-HeaderInfos__ExceedingPayers" $
+  R.divClass "g-PaymentHeaderInfos__ExceedingPayers" $
     flip mapM_ payers $ \payer ->
       R.elClass "span" "exceedingPayer" $ do
         R.elClass "span" "userName" $
@@ -72,7 +70,7 @@ infos
   -> Int
   -> m ()
 infos users currency repartition paymentCount =
-  R.divClass "g-HeaderInfos__Repartition" $ do
+  R.divClass "g-PaymentHeaderInfos__Repartition" $ do
 
     R.elClass "span" "total" $ do
       R.text $
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index f47b627..6bc1614 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -3,6 +3,7 @@ module View.Payment.Payment
   , In(..)
   ) where
 
+import           Control.Monad.IO.Class   (liftIO)
 import qualified Data.Maybe               as Maybe
 import           Data.Text                (Text)
 import qualified Data.Text                as T
@@ -12,9 +13,8 @@ import           Reflex.Dom               (Dynamic, Event, MonadWidget, Reflex)
 import qualified Reflex.Dom               as R
 
 import           Common.Model             (Currency, Frequency, Income (..),
-                                           Payment (..), PaymentCategory (..),
-                                           PaymentId, PaymentPage (..),
-                                           SavedPayment (..), User, UserId)
+                                           Payment (..), PaymentId,
+                                           PaymentPage (..), User, UserId)
 import qualified Common.Util.Text         as T
 
 import qualified Component.Pages          as Pages
@@ -22,8 +22,8 @@ import           Loadable                 (Loadable (..))
 import qualified Loadable
 import qualified Util.Ajax                as AjaxUtil
 import qualified Util.Reflex              as ReflexUtil
+import qualified View.Payment.HeaderForm  as HeaderForm
 import qualified View.Payment.HeaderInfos as HeaderInfos
--- import qualified View.Payment.HeaderForm as HeaderForm
 import qualified View.Payment.Reducer     as Reducer
 import qualified View.Payment.Table       as Table
 
@@ -36,15 +36,16 @@ data In t = In
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
 
-  categoriesEvent <- (AjaxUtil.getNow "api/categories")
+  categories <- AjaxUtil.getNow "api/categories"
 
-  R.dyn . R.ffor categoriesEvent . Loadable.view $ \categories -> do
+  R.dyn . R.ffor categories . Loadable.view $ \categories -> do
 
     rec
       payments <- Reducer.reducer $ Reducer.In
-        { Reducer._in_newPage      = newPage
-        , Reducer._in_currentPage  = currentPage
-        , Reducer._in_addPayment    = R.leftmost [headerAddPayment, tableAddPayment]
+        { Reducer._in_page          = page
+        , Reducer._in_search        = HeaderForm._out_search form
+        , Reducer._in_frequency     = HeaderForm._out_frequency form
+        , Reducer._in_addPayment    = addPayment
         , Reducer._in_editPayment   = editPayment
         , Reducer._in_deletePayment = deletePayment
         }
@@ -52,16 +53,25 @@ view input = do
       let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
           eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
 
-      newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
-      currentPage <- R.holdDyn 1 newPage
-      -- headerAddPayment <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
-      let headerAddPayment = R.never
+      let addPayment =
+            R.leftmost
+              [ tableAddPayment
+              , HeaderForm._out_addPayment form
+              ]
+
+      page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
       tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
       editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
       deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
-      result <- R.dyn . R.ffor ((,) <$> payments <*> currentPage) $ \(is, p) ->
-        flip Loadable.view is $ \(PaymentPage header payments paymentCategories count) -> do
+      form <- HeaderForm.view $ HeaderForm.In
+        { HeaderForm._in_reset             = () <$ addPayment
+        , HeaderForm._in_categories        = categories
+        }
+
+      result <- R.dyn . R.ffor payments $
+        Loadable.view $ \(PaymentPage page header payments count) -> do
+
           HeaderInfos.view $ HeaderInfos.In
             { HeaderInfos._in_users = _in_users input
             , HeaderInfos._in_currency = _in_currency input
@@ -75,13 +85,12 @@ view input = do
             , Table._in_categories = categories
             , Table._in_currency = _in_currency input
             , Table._in_payments = payments
-            , Table._in_paymentCategories = paymentCategories
             }
 
           pages <- Pages.view $ Pages.In
             { Pages._in_total = R.constDyn count
             , Pages._in_perPage = Reducer.perPage
-            , Pages._in_page = p
+            , Pages._in_page = page
             }
 
           return ((), table, pages)
@@ -89,137 +98,3 @@ view input = do
     return ()
 
   return ()
-
-
--- view :: forall t m. MonadWidget t m => In t -> m ()
--- view input = do
---   R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
---
---     R.elClass "main" "payment" $ do
---       rec
---         let addPayment = R.leftmost
---               -- [ Header._out_addPayment header
---               [ Table2._out_addPayment table
---               ]
---
---             paymentsPerPage = 7
---
---         payments <- reducePayments
---           (_init_payments init)
---           (_savedPayment_payment <$> addPayment)
---           (_savedPayment_payment <$> Table2._out_editPayment table)
---           (Table2._out_deletePayment table)
---
---         paymentCategories <- reducePaymentCategories
---           (_init_paymentCategories init)
---           payments
---           (_savedPayment_paymentCategory <$> addPayment)
---           (_savedPayment_paymentCategory <$> Table2._out_editPayment table)
---           (Table2._out_deletePayment table)
---
---         -- (searchNameEvent, searchName) <-
---         --   debounceSearchName (Header._out_searchName header)
---
---         -- let searchPayments =
---         --       getSearchPayments searchName (Header._out_searchFrequency header) payments
---
---         -- header <- Header.view $ Header.In
---         --   { Header._in_init = init
---         --   , Header._in_currency = _in_currency input
---         --   , Header._in_payments = payments
---         --   , Header._in_searchPayments = searchPayments
---         --   , Header._in_paymentCategories = paymentCategories
---         --   }
---
---         table <- Table2.view $ Table2.In
---           { Table2._in_init = init
---           , Table2._in_currency = _in_currency input
---           , Table2._in_currentUser = _in_currentUser input
---           , Table2._in_currentPage = Pages2._out_currentPage pages
---           , Table2._in_payments = payments
---           , Table2._in_perPage = paymentsPerPage
---           , Table2._in_paymentCategories = paymentCategories
---           }
---
---         pages <- Pages2.view $ Pages2.In
---           { Pages2._in_total = length <$> payments
---           , Pages2._in_perPage = paymentsPerPage
---           , Pages2._in_reset = R.never
---               -- [ () <$ searchNameEvent
---               -- [ () <$ Header._out_addPayment header
---               -- ]
---           }
---
---       pure ()
---
---   return ()
---
--- -- debounceSearchName
--- --   :: forall t m. MonadWidget t m
--- --   => Dynamic t Text
--- --   -> m (Event t Text, Dynamic t Text)
--- -- debounceSearchName searchName = do
--- --   event <- R.debounce (0.5 :: NominalDiffTime) (R.updated searchName)
--- --   dynamic <- R.holdDyn "" event
--- --   return (event, dynamic)
---
--- reducePayments
---   :: forall t m. MonadWidget t m
---   => [Payment]
---   -> Event t Payment -- add payment
---   -> Event t Payment -- edit payment
---   -> Event t Payment -- delete payment
---   -> m (Dynamic t [Payment])
--- reducePayments initPayments addPayment editPayment deletePayment =
---   R.foldDyn id initPayments $ R.leftmost
---     [ (:) <$> addPayment
---     , R.ffor editPayment (\p -> (p:) . filter ((/= (_payment_id p)) . _payment_id))
---     , R.ffor deletePayment (\p -> filter ((/= (_payment_id p)) . _payment_id))
---     ]
---
--- reducePaymentCategories
---   :: forall t m. MonadWidget t m
---   => [PaymentCategory]
---   -> Dynamic t [Payment]      -- payments
---   -> Event t PaymentCategory  -- add payment category
---   -> Event t PaymentCategory  -- edit payment category
---   -> Event t Payment          -- delete payment
---   -> m (Dynamic t [PaymentCategory])
--- reducePaymentCategories
---   initPaymentCategories
---   payments
---   addPaymentCategory
---   editPaymentCategory
---   deletePayment
---     =
---   R.foldDyn id initPaymentCategories $ R.leftmost
---     [ (:) <$> addPaymentCategory
---     , R.ffor editPaymentCategory (\pc -> (pc:) . filter ((/= (_paymentCategory_name pc)) . _paymentCategory_name))
---     , R.ffor deletePaymentName (\name -> filter ((/=) (T.toLower name) . _paymentCategory_name))
---     ]
---   where
---     deletePaymentName =
---       R.attachWithMaybe
---         (\ps p ->
---           if any (\p2 -> _payment_id p2 /= _payment_id p && lowerName p2 == lowerName p) ps then
---             Nothing
---           else
---             Just (_payment_name p))
---         (R.current payments)
---         deletePayment
---     lowerName = T.toLower . _payment_name
---
--- -- getSearchPayments
--- --   :: forall t. Reflex t
--- --   => Dynamic t Text
--- --   -> Dynamic t Frequency
--- --   -> Dynamic t [Payment]
--- --   -> Dynamic t [Payment]
--- -- getSearchPayments name frequency payments = do
--- --   n <- name
--- --   f <- frequency
--- --   ps <- payments
--- --   pure $ flip filter ps (\p ->
--- --     (  (T.search n (_payment_name p) || T.search n (T.pack . show . _payment_cost $ p))
--- --     && (_payment_frequency p == f)
--- --     ))
diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
index 0c70f8a..0b6c041 100644
--- a/client/src/View/Payment/Reducer.hs
+++ b/client/src/View/Payment/Reducer.hs
@@ -2,14 +2,16 @@ module View.Payment.Reducer
   ( perPage
   , reducer
   , In(..)
+  , Params(..)
   ) where
 
 import           Data.Text    (Text)
 import qualified Data.Text    as T
+import           Data.Time    (NominalDiffTime)
 import           Reflex.Dom   (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom   as R
 
-import           Common.Model (PaymentPage)
+import           Common.Model (Frequency (..), PaymentPage)
 
 import           Loadable     (Loadable (..))
 import qualified Loadable     as Loadable
@@ -19,48 +21,99 @@ perPage :: Int
 perPage = 7
 
 data In t a b c = In
-  { _in_newPage       :: Event t Int
-  , _in_currentPage   :: Dynamic t Int
+  { _in_page          :: Event t Int
+  , _in_search        :: Event t Text
+  , _in_frequency     :: Event t Frequency
   , _in_addPayment    :: Event t a
   , _in_editPayment   :: Event t b
   , _in_deletePayment :: Event t c
   }
 
 data Action
-  = LoadPage Int
+  = LoadPage
   | GetResult (Either Text PaymentPage)
 
+data Params = Params
+  { _params_page      :: Int
+  , _params_search    :: Text
+  , _params_frequency :: Frequency
+  } deriving (Show)
+
+initParams = Params 1 "" Punctual
+
+data Msg
+  = Page Int
+  | Search Text
+  | Frequency Common.Model.Frequency
+  | ResetSearch
+  deriving Show
+
 reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
 reducer input = do
 
   postBuild <- R.getPostBuild
 
-  let loadPage =
+  debouncedSearch <- R.debounce (1 :: NominalDiffTime) (_in_search input)
+
+  params <- R.foldDynMaybe
+    (\msg params -> case msg of
+      Page page     ->
+        Just $ params { _params_page = page }
+
+      Search ""     ->
+        if _params_search params == "" then
+          Nothing
+
+        else
+          Just $ initParams { _params_frequency = _params_frequency params }
+
+      Search search ->
+        Just $ params { _params_search = search, _params_page = _params_page initParams }
+
+      Frequency frequency ->
+        Just $ params { _params_frequency = frequency }
+
+      ResetSearch   ->
+        Just $ initParams { _params_frequency = _params_frequency params }
+    )
+    initParams
+    (R.leftmost
+      [ Page <$> _in_page input
+      , Search <$> debouncedSearch
+      , Frequency <$> _in_frequency input
+      , ResetSearch <$ _in_addPayment input
+      ])
+
+  let paramsEvent =
         R.leftmost
-          [ 1 <$ postBuild
-          , _in_newPage input
-          , 1 <$ _in_addPayment input
-          , R.tag (R.current $ _in_currentPage input) (_in_editPayment input)
-          , R.tag (R.current $ _in_currentPage input) (_in_deletePayment input)
+          [ initParams <$ postBuild
+          , R.updated params
+          , R.tag (R.current params) (_in_editPayment input)
+          , R.tag (R.current params) (_in_deletePayment input)
           ]
 
-  getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+  getResult <- AjaxUtil.get (pageUrl <$> paramsEvent)
+
 
   R.foldDyn
     (\action _ -> case action of
-      LoadPage _                 -> Loading
+      LoadPage                   -> Loading
       GetResult (Left err)       -> Error err
       GetResult (Right payments) -> Loaded payments
     )
     Loading
     (R.leftmost
-      [ LoadPage <$> loadPage
+      [ LoadPage <$ paramsEvent
       , GetResult <$> getResult
       ])
 
   where
-    pageUrl p =
+    pageUrl (Params page search frequency) =
       "api/payments?page="
-      <> (T.pack . show $ p)
+      <> (T.pack . show $ page)
       <> "&perPage="
       <> (T.pack . show $ perPage)
+      <> "&search="
+      <> search
+      <> "&frequency="
+      <> (T.pack $ show frequency)
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index dde5168..59ac890 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -13,7 +13,6 @@ import           Reflex.Dom              (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom              as R
 
 import           Common.Model            (Category (..), Currency, Payment (..),
-                                          PaymentCategory (..), SavedPayment,
                                           User (..), UserId)
 import qualified Common.Model            as CM
 import qualified Common.Msg              as Msg
@@ -26,17 +25,16 @@ import qualified Util.Either             as EitherUtil
 import qualified View.Payment.Form       as Form
 
 data In t = In
-  { _in_users             :: [User]
-  , _in_currentUser       :: UserId
-  , _in_categories        :: [Category]
-  , _in_currency          :: Currency
-  , _in_payments          :: [Payment]
-  , _in_paymentCategories :: [PaymentCategory]
+  { _in_users       :: [User]
+  , _in_currentUser :: UserId
+  , _in_categories  :: [Category]
+  , _in_currency    :: Currency
+  , _in_payments    :: [Payment]
   }
 
 data Out t = Out
-  { _out_add    :: Event t SavedPayment
-  , _out_edit   :: Event t SavedPayment
+  { _out_add    :: Event t Payment
+  , _out_edit   :: Event t Payment
   , _out_delete :: Event t Payment
   }
 
@@ -50,18 +48,15 @@ view input = do
       cell
         (_in_users input)
         (_in_categories input)
-        (_in_paymentCategories input)
         (_in_currency input)
     , Table._in_cloneModal = \payment ->
       Form.view $ Form.In
         { Form._in_categories = _in_categories input
-        , Form._in_paymentCategories = _in_paymentCategories input
         , Form._in_operation = Form.Clone payment
         }
     , Table._in_editModal = \payment ->
       Form.view $ Form.In
         { Form._in_categories = _in_categories input
-        , Form._in_paymentCategories = _in_paymentCategories input
         , Form._in_operation = Form.Edit payment
         }
     , Table._in_deleteModal = \payment ->
@@ -101,12 +96,11 @@ cell
   :: forall t m. MonadWidget t m
   => [User]
   -> [Category]
-  -> [PaymentCategory]
   -> Currency
   -> Header
   -> Payment
   -> m ()
-cell users categories paymentCategories currency header payment =
+cell users categories currency header payment =
   case header of
     NameHeader ->
       R.text $ _payment_name payment
@@ -120,7 +114,7 @@ cell users categories paymentCategories currency header payment =
     CategoryHeader ->
       let
         category =
-          findCategory categories paymentCategories (_payment_name payment)
+          L.find ((== (_payment_category payment)) . _category_id) categories
 
         attrs =
           case category of
@@ -144,10 +138,3 @@ cell users categories paymentCategories currency header payment =
 
         R.elClass "span" "longDate" $
           R.text . Format.longDay . _payment_date $ payment
-
-findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
-findCategory categories paymentCategories paymentName = do
-  paymentCategory <- L.find
-    ((== T.toLower paymentName) . _paymentCategory_name)
-    paymentCategories
-  L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
-- 
cgit v1.2.3


From 3c67fcf1d524811a18f0c4db3ef6eed1270b9a12 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 17 Nov 2019 19:55:22 +0100
Subject: Hide date from monthly payments

---
 client/src/View/Payment/Form.hs       | 51 +++++++++++++++++++----------------
 client/src/View/Payment/HeaderForm.hs | 20 ++++++++------
 client/src/View/Payment/Payment.hs    |  3 ++-
 client/src/View/Payment/Table.hs      | 40 ++++++++++++++++-----------
 4 files changed, 67 insertions(+), 47 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 6c3c1e8..99dce13 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -43,10 +43,11 @@ import qualified Util.Validation           as ValidationUtil
 data In t = In
   { _in_categories :: [Category]
   , _in_operation  :: Operation t
+  , _in_frequency  :: Frequency
   }
 
 data Operation t
-  = New (Dynamic t Frequency)
+  = New
   | Clone Payment
   | Edit Payment
 
@@ -92,18 +93,23 @@ view input cancel = do
         (cost <$ reset)
         confirm)
 
-      d <- date
-
-      date <- Input._out_raw <$> (Input.view
-        (Input.defaultIn
-          { Input._in_label = Msg.get Msg.Payment_Date
-          , Input._in_initialValue = d
-          , Input._in_inputType = "date"
-          , Input._in_hasResetButton = False
-          , Input._in_validation = PaymentValidation.date
-          })
-        (d <$ reset)
-        confirm)
+      currentDate <- date
+
+      date <-
+        case frequency of
+          Punctual -> do
+            Input._out_raw <$> (Input.view
+              (Input.defaultIn
+                { Input._in_label = Msg.get Msg.Payment_Date
+                , Input._in_initialValue = currentDate
+                , Input._in_inputType = "date"
+                , Input._in_hasResetButton = False
+                , Input._in_validation = PaymentValidation.date
+                })
+              (currentDate <$ reset)
+              confirm)
+          Monthly ->
+            return . R.constDyn $ currentDate
 
       setCategory <-
         R.debounce  (1 :: NominalDiffTime) (R.updated $ Input._out_raw name)
@@ -125,13 +131,12 @@ view input cancel = do
         c <- cost
         d <- date
         cat <- category
-        f <- frequency
         return (mkPayload
           <$> ValidationUtil.nelError n
           <*> V.Success c
           <*> V.Success d
           <*> ValidationUtil.nelError cat
-          <*> V.Success f)
+          <*> V.Success frequency)
 
     frequencies =
       M.fromList
@@ -144,7 +149,7 @@ view input cancel = do
 
     category =
       case op of
-        New _   -> -1
+        New     -> -1
         Clone p -> _payment_category p
         Edit p  -> _payment_category p
 
@@ -152,13 +157,13 @@ view input cancel = do
 
     name =
       case op of
-        New _   -> ""
+        New     -> ""
         Clone p -> _payment_name p
         Edit p  -> _payment_name p
 
     cost =
       case op of
-        New _   -> ""
+        New     -> ""
         Clone p -> T.pack . show . _payment_cost $ p
         Edit p  -> T.pack . show . _payment_cost $ p
 
@@ -166,19 +171,19 @@ view input cancel = do
       currentDay <- liftIO $ Clock.getCurrentTime >>= TimeUtil.timeToDay
       return . T.pack . Calendar.showGregorian $
         case op of
-          New _   -> currentDay
+          New     -> currentDay
           Clone p -> currentDay
           Edit p  -> _payment_date p
 
     frequency =
       case op of
-        New f   -> f
-        Clone p -> R.constDyn $ _payment_frequency p
-        Edit p  -> R.constDyn $ _payment_frequency p
+        New     -> _in_frequency input
+        Clone p -> _payment_frequency p
+        Edit p  -> _payment_frequency p
 
     headerLabel =
       case op of
-        New _   -> Msg.get Msg.Payment_Add
+        New     -> Msg.get Msg.Payment_Add
         Clone _ -> Msg.get Msg.Payment_CloneLong
         Edit _  -> Msg.get Msg.Payment_EditLong
 
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
index c8ca4d9..0ee0cd3 100644
--- a/client/src/View/Payment/HeaderForm.hs
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -18,6 +18,7 @@ import qualified Component.Button  as Button
 import qualified Component.Input   as Input
 import qualified Component.Modal   as Modal
 import qualified Component.Select  as Select
+import qualified Util.Reflex       as ReflexUtil
 import qualified View.Payment.Form as Form
 
 data In t = In
@@ -65,14 +66,17 @@ view input =
           { Button._in_class = R.constDyn "addPayment"
           })
 
-    addPayment <- Modal.view $ Modal.In
-      { Modal._in_show    = addPaymentButton
-      , Modal._in_content =
-        Form.view $ Form.In
-          { Form._in_categories = _in_categories input
-          , Form._in_operation = Form.New frequency
-          }
-      }
+    addPayment <-
+      (R.dyn . R.ffor frequency $ \frequency ->
+        Modal.view $ Modal.In
+          { Modal._in_show    = addPaymentButton
+          , Modal._in_content =
+            Form.view $ Form.In
+              { Form._in_categories = _in_categories input
+              , Form._in_operation = Form.New
+              , Form._in_frequency = frequency
+              }
+          }) >>= ReflexUtil.flatten
 
     return $ Out
       { _out_search = R.updated searchName
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index 6bc1614..a34d2f4 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -70,7 +70,7 @@ view input = do
         }
 
       result <- R.dyn . R.ffor payments $
-        Loadable.view $ \(PaymentPage page header payments count) -> do
+        Loadable.view $ \(PaymentPage page frequency header payments count) -> do
 
           HeaderInfos.view $ HeaderInfos.In
             { HeaderInfos._in_users = _in_users input
@@ -85,6 +85,7 @@ view input = do
             , Table._in_categories = categories
             , Table._in_currency = _in_currency input
             , Table._in_payments = payments
+            , Table._in_frequency = frequency
             }
 
           pages <- Pages.view $ Pages.In
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 59ac890..f9215bc 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -12,7 +12,8 @@ import qualified Data.Text               as T
 import           Reflex.Dom              (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom              as R
 
-import           Common.Model            (Category (..), Currency, Payment (..),
+import           Common.Model            (Category (..), Currency,
+                                          Frequency (..), Payment (..),
                                           User (..), UserId)
 import qualified Common.Model            as CM
 import qualified Common.Msg              as Msg
@@ -30,6 +31,7 @@ data In t = In
   , _in_categories  :: [Category]
   , _in_currency    :: Currency
   , _in_payments    :: [Payment]
+  , _in_frequency   :: Frequency
   }
 
 data Out t = Out
@@ -42,22 +44,25 @@ view :: forall t m. MonadWidget t m => In t -> m (Out t)
 view input = do
 
   table <- Table.view $ Table.In
-    { Table._in_headerLabel = headerLabel
+    { Table._in_headerLabel = headerLabel (_in_frequency input)
     , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input
     , Table._in_cell =
       cell
         (_in_users input)
         (_in_categories input)
+        (_in_frequency input)
         (_in_currency input)
     , Table._in_cloneModal = \payment ->
       Form.view $ Form.In
         { Form._in_categories = _in_categories input
         , Form._in_operation = Form.Clone payment
+        , Form._in_frequency = _in_frequency input
         }
     , Table._in_editModal = \payment ->
       Form.view $ Form.In
         { Form._in_categories = _in_categories input
         , Form._in_operation = Form.Edit payment
+        , Form._in_frequency = _in_frequency input
         }
     , Table._in_deleteModal = \payment ->
       ConfirmDialog.view $ ConfirmDialog.In
@@ -85,22 +90,24 @@ data Header
   | DateHeader
   deriving (Eq, Show, Bounded, Enum)
 
-headerLabel :: Header -> Text
-headerLabel NameHeader     = Msg.get Msg.Payment_Name
-headerLabel CostHeader     = Msg.get Msg.Payment_Cost
-headerLabel UserHeader     = Msg.get Msg.Payment_User
-headerLabel CategoryHeader = Msg.get Msg.Payment_Category
-headerLabel DateHeader     = Msg.get Msg.Payment_Date
+headerLabel :: Frequency -> Header -> Text
+headerLabel _ NameHeader        = Msg.get Msg.Payment_Name
+headerLabel _ CostHeader        = Msg.get Msg.Payment_Cost
+headerLabel _ UserHeader        = Msg.get Msg.Payment_User
+headerLabel _ CategoryHeader    = Msg.get Msg.Payment_Category
+headerLabel Punctual DateHeader = Msg.get Msg.Payment_Date
+headerLabel Monthly DateHeader  = ""
 
 cell
   :: forall t m. MonadWidget t m
   => [User]
   -> [Category]
+  -> Frequency
   -> Currency
   -> Header
   -> Payment
   -> m ()
-cell users categories currency header payment =
+cell users categories frequency currency header payment =
   case header of
     NameHeader ->
       R.text $ _payment_name payment
@@ -132,9 +139,12 @@ cell users categories currency header payment =
             Maybe.fromMaybe "" (_category_name <$> category)
 
     DateHeader ->
-      do
-        R.elClass "span" "shortDate" $
-          R.text . Format.shortDay . _payment_date $ payment
-
-        R.elClass "span" "longDate" $
-          R.text . Format.longDay . _payment_date $ payment
+      if frequency == Punctual then
+        do
+          R.elClass "span" "shortDate" $
+            R.text . Format.shortDay . _payment_date $ payment
+
+          R.elClass "span" "longDate" $
+            R.text . Format.longDay . _payment_date $ payment
+      else
+        R.blank
-- 
cgit v1.2.3


From 54628c70cb33de5e4309c35b9f6b57bbe9f7a07b Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 24 Nov 2019 16:19:53 +0100
Subject: Compute cumulative income with a DB query

---
 client/src/Loadable.hs             | 37 +++++++++++++++++++++++++++++++++++
 client/src/View/Income/Income.hs   | 15 +++++++-------
 client/src/View/Income/Reducer.hs  | 40 ++++++++++++++++++--------------------
 client/src/View/Payment/Form.hs    |  1 +
 client/src/View/Payment/Payment.hs | 18 ++++++++---------
 client/src/View/Payment/Reducer.hs | 30 +++++++++++++---------------
 6 files changed, 86 insertions(+), 55 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index 2b9008a..9a14b3f 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -1,9 +1,12 @@
 module Loadable
   ( Loadable (..)
+  , Loadable2 (..)
   , fromEvent
   , view
+  , view2
   ) where
 
+import qualified Data.Map     as M
 import           Reflex.Dom   (MonadWidget)
 import qualified Reflex.Dom   as R
 
@@ -50,3 +53,37 @@ view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe
 view _ Loading  = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
 view _ (Error e)  = R.text e >> return Nothing
 view f (Loaded x) = Just <$> f x
+
+data Loadable2 t a = Loadable2
+  { _loadable_isLoading :: Dynamic t Bool
+  , _loadable_value     :: Dynamic t (Maybe a)
+  }
+
+view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b))
+view2 (Loadable2 isLoading value) f =
+  withLoader isLoading $
+    R.dyn . R.ffor value . viewMaybe $ f
+
+  where
+    viewMaybe _ Nothing  = return Nothing
+    viewMaybe f (Just x) = Just <$> f x
+
+withLoader
+  :: forall t m a. MonadWidget t m
+  => Dynamic t Bool
+  -> m a
+  -> m a
+withLoader isLoading block =
+  R.divClass "g-Loadable" $ do
+    R.elDynAttr "div" (spinnerAttrs <$> isLoading) $
+      R.divClass "spinner" R.blank
+    R.elDynAttr "div" (blockAttrs <$> isLoading) $
+      block
+  where
+    spinnerAttrs l = M.singleton "class" $
+      "g-Loadable__Spinner"
+      <> (if l then " g-Loadable__Spinner--Loading" else "")
+
+    blockAttrs l = M.singleton "class" $
+      "g-Loadable__Content"
+      <> (if l then " g-Loadable__Content--Loading" else "")
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index d82ab4d..fa2585d 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -19,6 +19,7 @@ import           Loadable            (Loadable (..))
 import qualified Loadable
 import qualified Util.Ajax           as AjaxUtil
 import qualified Util.Reflex         as ReflexUtil
+import qualified Util.Reflex         as ReflexUtil
 import qualified View.Income.Header  as Header
 import           View.Income.Init    (Init (..))
 import qualified View.Income.Reducer as Reducer
@@ -33,9 +34,8 @@ data In t = In
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
   rec
-    incomes <- Reducer.reducer $ Reducer.In
-      { Reducer._in_newPage      = newPage
-      , Reducer._in_currentPage  = currentPage
+    incomePage <- Reducer.reducer $ Reducer.In
+      { Reducer._in_page         = page
       , Reducer._in_addIncome    = R.leftmost [headerAddIncome, tableAddIncome]
       , Reducer._in_editIncome   = editIncome
       , Reducer._in_deleteIncome = deleteIncome
@@ -44,15 +44,14 @@ view input = do
     let eventFromResult :: forall a. ((Header.Out t, Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
         eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
 
-    newPage <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
-    currentPage <- R.holdDyn 1 newPage
+    page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
     headerAddIncome <- eventFromResult $ Header._out_add . (\(a, _, _) -> a)
     tableAddIncome <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
     editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
     deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
-    result <- R.dyn . R.ffor ((,) <$> incomes <*> currentPage) $ \(is, p) ->
-      flip Loadable.view is $ \(IncomePage header incomes count) -> do
+    result <- Loadable.view2 incomePage $
+      \(IncomePage page header incomes count) -> do
         header <- Header.view $ Header.In
           { Header._in_users = _in_users input
           , Header._in_header = header
@@ -69,7 +68,7 @@ view input = do
         pages <- Pages.view $ Pages.In
           { Pages._in_total = R.constDyn count
           , Pages._in_perPage = Reducer.perPage
-          , Pages._in_page = p
+          , Pages._in_page = page
           }
 
         return (header, table, pages)
diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs
index 092d9b3..391890f 100644
--- a/client/src/View/Income/Reducer.hs
+++ b/client/src/View/Income/Reducer.hs
@@ -11,53 +11,51 @@ import qualified Reflex.Dom   as R
 
 import           Common.Model (IncomePage)
 
-import           Loadable     (Loadable (..))
-import qualified Loadable     as Loadable
+import           Loadable     (Loadable2 (..))
 import qualified Util.Ajax    as AjaxUtil
+import qualified Util.Either  as EitherUtil
 
 perPage :: Int
 perPage = 7
 
 data In t a b c = In
-  { _in_newPage      :: Event t Int
-  , _in_currentPage  :: Dynamic t Int
+  { _in_page         :: Event t Int
   , _in_addIncome    :: Event t a
   , _in_editIncome   :: Event t b
   , _in_deleteIncome :: Event t c
   }
 
-data Action
-  = LoadPage Int
-  | GetResult (Either Text IncomePage)
-
-reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage))
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage)
 reducer input = do
 
   postBuild <- R.getPostBuild
 
+  currentPage <- R.holdDyn 1 (_in_page input)
+
   let loadPage =
         R.leftmost
           [ 1 <$ postBuild
-          , _in_newPage input
+          , _in_page input
           , 1 <$ _in_addIncome input
-          , R.tag (R.current $ _in_currentPage input) (_in_editIncome input)
-          , R.tag (R.current $ _in_currentPage input) (_in_deleteIncome input)
+          , R.tag (R.current currentPage) (_in_editIncome input)
+          , R.tag (R.current currentPage) (_in_deleteIncome input)
           ]
 
   getResult <- AjaxUtil.get $ fmap pageUrl loadPage
 
-  R.foldDyn
-    (\action _ -> case action of
-      LoadPage _                -> Loading
-      GetResult (Left err)      -> Error err
-      GetResult (Right incomes) -> Loaded incomes
-    )
-    Loading
+  isLoading <- R.holdDyn
+    True
     (R.leftmost
-      [ LoadPage <$> loadPage
-      , GetResult <$> getResult
+      [ True <$ loadPage
+      , False <$ getResult
       ])
 
+  incomePage <- R.holdDyn
+    Nothing
+    (fmap EitherUtil.eitherToMaybe getResult)
+
+  return $ Loadable2 isLoading incomePage
+
   where
     pageUrl p =
       "api/incomes?page="
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 99dce13..064b5b3 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -113,6 +113,7 @@ view input cancel = do
 
       setCategory <-
         R.debounce  (1 :: NominalDiffTime) (R.updated $ Input._out_raw name)
+          >>= (return . R.ffilter (\name -> T.length name >= 3))
           >>= (Ajax.get . (fmap ("/api/payment/category?name=" <>)))
           >>= (return . R.mapMaybe (join . EitherUtil.eitherToMaybe))
 
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index a34d2f4..a97c3df 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -41,7 +41,7 @@ view input = do
   R.dyn . R.ffor categories . Loadable.view $ \categories -> do
 
     rec
-      payments <- Reducer.reducer $ Reducer.In
+      paymentPage <- Reducer.reducer $ Reducer.In
         { Reducer._in_page          = page
         , Reducer._in_search        = HeaderForm._out_search form
         , Reducer._in_frequency     = HeaderForm._out_frequency form
@@ -50,7 +50,7 @@ view input = do
         , Reducer._in_deletePayment = deletePayment
         }
 
-      let eventFromResult :: forall a. (((), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+      let eventFromResult :: forall a. ((Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
           eventFromResult op = ReflexUtil.flatten . fmap (Maybe.fromMaybe R.never . fmap op) $ result
 
       let addPayment =
@@ -59,18 +59,18 @@ view input = do
               , HeaderForm._out_addPayment form
               ]
 
-      page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
-      tableAddPayment <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
-      editPayment <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
-      deletePayment <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
+      page <- eventFromResult $ Pages._out_newPage . snd
+      tableAddPayment <- eventFromResult $ Table._out_add . fst
+      editPayment <- eventFromResult $ Table._out_edit . fst
+      deletePayment <- eventFromResult $ Table._out_delete . fst
 
       form <- HeaderForm.view $ HeaderForm.In
         { HeaderForm._in_reset             = () <$ addPayment
         , HeaderForm._in_categories        = categories
         }
 
-      result <- R.dyn . R.ffor payments $
-        Loadable.view $ \(PaymentPage page frequency header payments count) -> do
+      result <- Loadable.view2 paymentPage $
+        \(PaymentPage page frequency header payments count) -> do
 
           HeaderInfos.view $ HeaderInfos.In
             { HeaderInfos._in_users = _in_users input
@@ -94,7 +94,7 @@ view input = do
             , Pages._in_page = page
             }
 
-          return ((), table, pages)
+          return (table, pages)
 
     return ()
 
diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
index 0b6c041..d221ff0 100644
--- a/client/src/View/Payment/Reducer.hs
+++ b/client/src/View/Payment/Reducer.hs
@@ -13,9 +13,9 @@ import qualified Reflex.Dom   as R
 
 import           Common.Model (Frequency (..), PaymentPage)
 
-import           Loadable     (Loadable (..))
-import qualified Loadable     as Loadable
+import           Loadable     (Loadable2 (..))
 import qualified Util.Ajax    as AjaxUtil
+import qualified Util.Either  as EitherUtil
 
 perPage :: Int
 perPage = 7
@@ -29,10 +29,6 @@ data In t a b c = In
   , _in_deletePayment :: Event t c
   }
 
-data Action
-  = LoadPage
-  | GetResult (Either Text PaymentPage)
-
 data Params = Params
   { _params_page      :: Int
   , _params_search    :: Text
@@ -48,7 +44,7 @@ data Msg
   | ResetSearch
   deriving Show
 
-reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage)
 reducer input = do
 
   postBuild <- R.getPostBuild
@@ -94,19 +90,19 @@ reducer input = do
 
   getResult <- AjaxUtil.get (pageUrl <$> paramsEvent)
 
-
-  R.foldDyn
-    (\action _ -> case action of
-      LoadPage                   -> Loading
-      GetResult (Left err)       -> Error err
-      GetResult (Right payments) -> Loaded payments
-    )
-    Loading
+  isLoading <- R.holdDyn
+    True
     (R.leftmost
-      [ LoadPage <$ paramsEvent
-      , GetResult <$> getResult
+      [ True <$ paramsEvent
+      , False <$ getResult
       ])
 
+  paymentPage <- R.holdDyn
+    Nothing
+    (fmap EitherUtil.eitherToMaybe getResult)
+
+  return $ Loadable2 isLoading paymentPage
+
   where
     pageUrl (Params page search frequency) =
       "api/payments?page="
-- 
cgit v1.2.3


From e622e8fdd2e40b4306b5cc724d8dfb76bf976242 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 25 Nov 2019 08:17:59 +0100
Subject: Remove Loadable2

---
 client/src/Loadable.hs             | 62 +++++++++++++++++++++++++-------------
 client/src/View/Income/Income.hs   |  2 +-
 client/src/View/Income/Reducer.hs  | 19 +++++-------
 client/src/View/Payment/Payment.hs |  4 +--
 client/src/View/Payment/Reducer.hs | 19 +++++-------
 5 files changed, 58 insertions(+), 48 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Loadable.hs b/client/src/Loadable.hs
index 9a14b3f..4806b08 100644
--- a/client/src/Loadable.hs
+++ b/client/src/Loadable.hs
@@ -1,9 +1,9 @@
 module Loadable
   ( Loadable (..)
-  , Loadable2 (..)
+  , fromEither
   , fromEvent
-  , view
-  , view2
+  , viewHideValueWhileLoading
+  , viewShowValueWhileLoading
   ) where
 
 import qualified Data.Map     as M
@@ -19,7 +19,7 @@ data Loadable t
   = Loading
   | Error Text
   | Loaded t
-  deriving Show
+  deriving (Eq, Show)
 
 instance Functor Loadable where
   fmap f Loading    = Loading
@@ -40,6 +40,10 @@ instance Monad Loadable where
   (Error e) >>= f = Error e
   (Loaded x) >>= f = f x
 
+fromEither :: forall a b. Either Text b -> Loadable b
+fromEither (Left err)    = Error err
+fromEither (Right value) = Loaded value
+
 fromEvent :: forall t m a. MonadWidget t m => Event t (Either Text a) -> m (Dynamic t (Loadable a))
 fromEvent =
   R.foldDyn
@@ -49,24 +53,38 @@ fromEvent =
     )
     Loading
 
-view :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
-view _ Loading  = (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
-view _ (Error e)  = R.text e >> return Nothing
-view f (Loaded x) = Just <$> f x
+viewHideValueWhileLoading :: forall t m a b. MonadWidget t m => (a -> m b) -> Loadable a -> m (Maybe b)
+viewHideValueWhileLoading f loadable =
+  case loadable of
+    Loading ->
+      (R.divClass "pageSpinner" $ R.divClass "spinner" $ R.blank) >> return Nothing
 
-data Loadable2 t a = Loadable2
-  { _loadable_isLoading :: Dynamic t Bool
-  , _loadable_value     :: Dynamic t (Maybe a)
-  }
+    Error err ->
+      R.text err >> return Nothing
 
-view2 :: forall t m a b. MonadWidget t m => Loadable2 t a -> (a -> m b) -> m (Event t (Maybe b))
-view2 (Loadable2 isLoading value) f =
-  withLoader isLoading $
-    R.dyn . R.ffor value . viewMaybe $ f
+    Loaded x ->
+      Just <$> f x
 
-  where
-    viewMaybe _ Nothing  = return Nothing
-    viewMaybe f (Just x) = Just <$> f x
+viewShowValueWhileLoading
+  :: forall t m a b. (MonadWidget t m, Eq a)
+  => Dynamic t (Loadable a)
+  -> (a -> m b)
+  -> m (Event t (Maybe b))
+viewShowValueWhileLoading loadable f = do
+
+  value <-
+    (R.foldDyn
+      (\l v1 ->
+        case l of
+          Loaded v2 -> Just v2
+          _         -> v1)
+      Nothing
+      (R.updated loadable)) >>= R.holdUniqDyn
+
+  withLoader (fmap ((==) Loading) loadable) $
+    R.dyn . R.ffor value $ \case
+      Nothing -> return Nothing
+      Just x -> Just <$> f x
 
 withLoader
   :: forall t m a. MonadWidget t m
@@ -75,10 +93,12 @@ withLoader
   -> m a
 withLoader isLoading block =
   R.divClass "g-Loadable" $ do
+    res <- R.elDynAttr "div" (blockAttrs <$> isLoading) $
+      block
     R.elDynAttr "div" (spinnerAttrs <$> isLoading) $
       R.divClass "spinner" R.blank
-    R.elDynAttr "div" (blockAttrs <$> isLoading) $
-      block
+    return res
+
   where
     spinnerAttrs l = M.singleton "class" $
       "g-Loadable__Spinner"
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index fa2585d..e83ba80 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -50,7 +50,7 @@ view input = do
     editIncome <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
     deleteIncome <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
-    result <- Loadable.view2 incomePage $
+    result <- Loadable.viewShowValueWhileLoading incomePage $
       \(IncomePage page header incomes count) -> do
         header <- Header.view $ Header.In
           { Header._in_users = _in_users input
diff --git a/client/src/View/Income/Reducer.hs b/client/src/View/Income/Reducer.hs
index 391890f..ea9f664 100644
--- a/client/src/View/Income/Reducer.hs
+++ b/client/src/View/Income/Reducer.hs
@@ -11,7 +11,8 @@ import qualified Reflex.Dom   as R
 
 import           Common.Model (IncomePage)
 
-import           Loadable     (Loadable2 (..))
+import           Loadable     (Loadable (..))
+import qualified Loadable     as Loadable
 import qualified Util.Ajax    as AjaxUtil
 import qualified Util.Either  as EitherUtil
 
@@ -25,7 +26,7 @@ data In t a b c = In
   , _in_deleteIncome :: Event t c
   }
 
-reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t IncomePage)
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable IncomePage))
 reducer input = do
 
   postBuild <- R.getPostBuild
@@ -43,19 +44,13 @@ reducer input = do
 
   getResult <- AjaxUtil.get $ fmap pageUrl loadPage
 
-  isLoading <- R.holdDyn
-    True
+  R.holdDyn
+    Loading
     (R.leftmost
-      [ True <$ loadPage
-      , False <$ getResult
+      [ Loading <$ loadPage
+      , Loadable.fromEither <$> getResult
       ])
 
-  incomePage <- R.holdDyn
-    Nothing
-    (fmap EitherUtil.eitherToMaybe getResult)
-
-  return $ Loadable2 isLoading incomePage
-
   where
     pageUrl p =
       "api/incomes?page="
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index a97c3df..8d0fee1 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -38,7 +38,7 @@ view input = do
 
   categories <- AjaxUtil.getNow "api/categories"
 
-  R.dyn . R.ffor categories . Loadable.view $ \categories -> do
+  R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do
 
     rec
       paymentPage <- Reducer.reducer $ Reducer.In
@@ -69,7 +69,7 @@ view input = do
         , HeaderForm._in_categories        = categories
         }
 
-      result <- Loadable.view2 paymentPage $
+      result <- Loadable.viewShowValueWhileLoading paymentPage $
         \(PaymentPage page frequency header payments count) -> do
 
           HeaderInfos.view $ HeaderInfos.In
diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
index d221ff0..7468097 100644
--- a/client/src/View/Payment/Reducer.hs
+++ b/client/src/View/Payment/Reducer.hs
@@ -13,7 +13,8 @@ import qualified Reflex.Dom   as R
 
 import           Common.Model (Frequency (..), PaymentPage)
 
-import           Loadable     (Loadable2 (..))
+import           Loadable     (Loadable (..))
+import qualified Loadable     as Loadable
 import qualified Util.Ajax    as AjaxUtil
 import qualified Util.Either  as EitherUtil
 
@@ -44,7 +45,7 @@ data Msg
   | ResetSearch
   deriving Show
 
-reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Loadable2 t PaymentPage)
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable PaymentPage))
 reducer input = do
 
   postBuild <- R.getPostBuild
@@ -90,19 +91,13 @@ reducer input = do
 
   getResult <- AjaxUtil.get (pageUrl <$> paramsEvent)
 
-  isLoading <- R.holdDyn
-    True
+  R.holdDyn
+    Loading
     (R.leftmost
-      [ True <$ paramsEvent
-      , False <$ getResult
+      [ Loading <$ paramsEvent
+      , Loadable.fromEither <$> getResult
       ])
 
-  paymentPage <- R.holdDyn
-    Nothing
-    (fmap EitherUtil.eitherToMaybe getResult)
-
-  return $ Loadable2 isLoading paymentPage
-
   where
     pageUrl (Params page search frequency) =
       "api/payments?page="
-- 
cgit v1.2.3


From 316bda10c6bec8b5ccc9e23f1f677c076205f046 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 8 Dec 2019 11:39:37 +0100
Subject: Add category page

---
 client/src/Component/ConfirmDialog.hs |   6 +-
 client/src/Component/Modal.hs         |   8 +--
 client/src/Component/ModalForm.hs     |  10 +--
 client/src/Component/Table.hs         |  18 +++---
 client/src/Component/Tag.hs           |  27 ++++++++
 client/src/Model/Route.hs             |   1 +
 client/src/Util/Ajax.hs               |  28 +++++++-
 client/src/View/App.hs                |  43 ++++++++-----
 client/src/View/Category/Category.hs  |  92 ++++++++++++++++++++++++++
 client/src/View/Category/Form.hs      | 117 ++++++++++++++++++++++++++++++++++
 client/src/View/Category/Reducer.hs   |  59 +++++++++++++++++
 client/src/View/Category/Table.hs     |  91 ++++++++++++++++++++++++++
 client/src/View/Header.hs             |   5 ++
 client/src/View/Income/Form.hs        |   2 +-
 client/src/View/Income/Header.hs      |   3 +-
 client/src/View/Income/Income.hs      |   1 -
 client/src/View/Income/Init.hs        |  11 ----
 client/src/View/Income/Table.hs       |  11 ++--
 client/src/View/Payment/Form.hs       |   2 +-
 client/src/View/Payment/HeaderForm.hs |   2 +-
 client/src/View/Payment/Payment.hs    |   2 +-
 client/src/View/Payment/Table.hs      |  30 ++++-----
 client/src/View/SignIn.hs             |   2 +-
 23 files changed, 488 insertions(+), 83 deletions(-)
 create mode 100644 client/src/Component/Tag.hs
 create mode 100644 client/src/View/Category/Category.hs
 create mode 100644 client/src/View/Category/Form.hs
 create mode 100644 client/src/View/Category/Reducer.hs
 create mode 100644 client/src/View/Category/Table.hs
 delete mode 100644 client/src/View/Income/Init.hs

(limited to 'client/src')

diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs
index 50e30ed..cf26593 100644
--- a/client/src/Component/ConfirmDialog.hs
+++ b/client/src/Component/ConfirmDialog.hs
@@ -13,12 +13,12 @@ import qualified Component.Modal  as Modal
 import qualified Util.Either      as EitherUtil
 import qualified Util.WaitFor     as WaitFor
 
-data In t m a = In
+data In t m = In
   { _in_header  :: Text
-  , _in_confirm :: Event t () -> m (Event t a)
+  , _in_confirm :: Event t () -> m (Event t ())
   }
 
-view :: forall t m a. MonadWidget t m => (In t m a) -> Modal.Content t m a
+view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m
 view input _ =
   R.divClass "confirm" $ do
     R.divClass "confirmHeader" $
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 08f2e74..46d3f64 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -20,14 +20,14 @@ import qualified Reflex.Dom.Class  as R
 import qualified Util.Reflex       as ReflexUtil
 
 -- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
-type Content t m a = Event t () -> m (Event t (), Event t a)
+type Content t m = Event t () -> m (Event t (), Event t ())
 
-data In t m a = In
+data In t m = In
   { _in_show    :: Event t ()
-  , _in_content :: Content t m a
+  , _in_content :: Content t m
   }
 
-view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a)
+view :: forall t m a. MonadWidget t m => In t m -> m (Event t ())
 view input = do
   rec
     let show = Show <$ (_in_show input)
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
index f5bf287..c56ff88 100644
--- a/client/src/Component/ModalForm.hs
+++ b/client/src/Component/ModalForm.hs
@@ -20,20 +20,20 @@ import qualified Util.Either        as EitherUtil
 import qualified Util.Validation    as ValidationUtil
 import qualified Util.WaitFor       as WaitFor
 
-data In m t a b e = In
+data In m t a e = In
   { _in_headerLabel :: Text
   , _in_form        :: m (Dynamic t (Validation e a))
-  , _in_ajax        :: Event t a -> m (Event t (Either Text b))
+  , _in_ajax        :: Event t a -> m (Event t (Either Text ()))
   }
 
-data Out t a = Out
+data Out t = Out
   { _out_hide     :: Event t ()
   , _out_cancel   :: Event t ()
   , _out_confirm  :: Event t ()
-  , _out_validate :: Event t a
+  , _out_validate :: Event t ()
   }
 
-view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b)
+view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t)
 view input =
   R.divClass "form" $ do
     R.divClass "formHeader" $
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index 2869c2d..f82cfa6 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -14,23 +14,23 @@ import qualified Component.Modal  as Modal
 import qualified Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
-data In m t h r a b c = In
+data In m t h r = In
   { _in_headerLabel :: h -> Text
   , _in_rows        :: [r]
   , _in_cell        :: h -> r -> m ()
-  , _in_cloneModal  :: r -> Modal.Content t m a
-  , _in_editModal   :: r -> Modal.Content t m b
-  , _in_deleteModal :: r -> Modal.Content t m c
+  , _in_cloneModal  :: r -> Modal.Content t m
+  , _in_editModal   :: r -> Modal.Content t m
+  , _in_deleteModal :: r -> Modal.Content t m
   , _in_isOwner     :: r -> Bool
   }
 
-data Out t a b c = Out
-  { _out_add    :: Event t a
-  , _out_edit   :: Event t b
-  , _out_delete :: Event t c
+data Out t = Out
+  { _out_add    :: Event t ()
+  , _out_edit   :: Event t ()
+  , _out_delete :: Event t ()
   }
 
-view :: forall t m h r a b c. (MonadWidget t m, Bounded h, Enum h)  => In m t h r a b c-> m (Out t a b c)
+view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h)  => In m t h r -> m (Out t)
 view input =
   R.divClass "table" $ do
     rec
diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs
new file mode 100644
index 0000000..f75b8d3
--- /dev/null
+++ b/client/src/Component/Tag.hs
@@ -0,0 +1,27 @@
+module Component.Tag
+  ( In(..)
+  , view
+  ) where
+
+import qualified Data.Map   as M
+import           Data.Text  (Text)
+import qualified Data.Text  as T
+import           Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+data In = In
+  { _in_text  :: Text
+  , _in_color :: Text
+  }
+
+view :: forall t m a. MonadWidget t m => In -> m ()
+view input =
+  R.elAttr "span" attrs $
+    R.text $ _in_text input
+
+  where
+    attrs =
+      M.fromList
+        [ ("class", "tag")
+        , ("style", T.concat [ "background-color: ", _in_color input ])
+        ]
diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs
index 420fe05..63e5d10 100644
--- a/client/src/Model/Route.hs
+++ b/client/src/Model/Route.hs
@@ -5,5 +5,6 @@ module Model.Route
 data Route
   = RootRoute
   | IncomeRoute
+  | CategoryRoute
   | NotFoundRoute
   deriving (Eq, Show)
diff --git a/client/src/Util/Ajax.hs b/client/src/Util/Ajax.hs
index dc56701..dcfd402 100644
--- a/client/src/Util/Ajax.hs
+++ b/client/src/Util/Ajax.hs
@@ -2,7 +2,9 @@ module Util.Ajax
   ( getNow
   , get
   , post
+  , postAndParseResult
   , put
+  , putAndParseResult
   , delete
   ) where
 
@@ -42,20 +44,38 @@ get url =
     R.performRequestAsync (R.ffor url $ \u -> jsonRequest "GET" u (Aeson.String ""))
 
 post
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text ()))
+post url input =
+  fmap checkResult <$>
+    R.performRequestAsync (jsonRequest "POST" url <$> input)
+
+postAndParseResult
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-post url input =
+postAndParseResult url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "POST" url <$> input)
 
 put
+  :: forall t m a. (MonadWidget t m, ToJSON a)
+  => Text
+  -> Event t a
+  -> m (Event t (Either Text ()))
+put url input =
+  fmap checkResult <$>
+    R.performRequestAsync (jsonRequest "PUT" url <$> input)
+
+putAndParseResult
   :: forall t m a b. (MonadWidget t m, ToJSON a, FromJSON b)
   => Text
   -> Event t a
   -> m (Event t (Either Text b))
-put url input =
+putAndParseResult url input =
   fmap getJsonResult <$>
     R.performRequestAsync (jsonRequest "PUT" url <$> input)
 
@@ -69,6 +89,10 @@ delete url fire = do
     (R.performRequestAsync $
       R.attachWith (\u _ -> request "DELETE" u ()) (R.current url) fire)
 
+checkResult :: XhrResponse -> Either Text ()
+checkResult response =
+  () <$ getResult response
+
 getJsonResult :: forall a. (FromJSON a) => XhrResponse -> Either Text a
 getJsonResult response =
   case getResult response of
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 2b346af..460d499 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,22 +2,23 @@ module View.App
   ( widget
   ) where
 
-import qualified Data.Text            as T
-import           Prelude              hiding (error, init)
-import           Reflex.Dom           (Dynamic, MonadWidget)
-import qualified Reflex.Dom           as R
-
-import           Common.Model         (Currency, Init (..), InitResult (..),
-                                       UserId)
-import qualified Common.Msg           as Msg
-
-import           Model.Route          (Route (..))
-import qualified Util.Router          as Router
-import qualified View.Header          as Header
-import qualified View.Income.Income   as Income
-import qualified View.NotFound        as NotFound
-import qualified View.Payment.Payment as Payment
-import qualified View.SignIn          as SignIn
+import qualified Data.Text              as T
+import           Prelude                hiding (error, init)
+import           Reflex.Dom             (Dynamic, MonadWidget)
+import qualified Reflex.Dom             as R
+
+import           Common.Model           (Currency, Init (..), InitResult (..),
+                                         UserId)
+import qualified Common.Msg             as Msg
+
+import           Model.Route            (Route (..))
+import qualified Util.Router            as Router
+import qualified View.Category.Category as Category
+import qualified View.Header            as Header
+import qualified View.Income.Income     as Income
+import qualified View.NotFound          as NotFound
+import qualified View.Payment.Payment   as Payment
+import qualified View.SignIn            as SignIn
 
 widget :: InitResult -> IO ()
 widget initResult =
@@ -72,6 +73,13 @@ signedWidget init route = do
         , Income._in_users = _init_users init
         }
 
+    CategoryRoute ->
+      Category.view $ Category.In
+        { Category._in_currentUser = _init_currentUser init
+        , Category._in_currency = _init_currency init
+        , Category._in_users = _init_users init
+        }
+
     NotFoundRoute ->
       NotFound.view
 
@@ -87,5 +95,8 @@ getRoute = do
     ["income"] ->
       IncomeRoute
 
+    ["category"] ->
+      CategoryRoute
+
     _ ->
       NotFoundRoute
diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs
new file mode 100644
index 0000000..77a331a
--- /dev/null
+++ b/client/src/View/Category/Category.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+module View.Category.Category
+  ( view
+  , In(..)
+  ) where
+
+import           Data.Aeson            (FromJSON)
+import qualified Data.Maybe            as Maybe
+import qualified Data.Text             as T
+import           Reflex.Dom            (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom            as R
+
+import           Common.Model          (Category, CategoryPage (..), Currency,
+                                        User, UserId)
+import qualified Common.Msg            as Msg
+
+import qualified Component.Button      as Button
+import qualified Component.Modal       as Modal
+import qualified Component.Pages       as Pages
+import           Loadable              (Loadable (..))
+import qualified Loadable
+import qualified Util.Ajax             as AjaxUtil
+import qualified Util.Reflex           as ReflexUtil
+import qualified Util.Reflex           as ReflexUtil
+import qualified View.Category.Form    as Form
+import qualified View.Category.Reducer as Reducer
+import qualified View.Category.Table   as Table
+
+data In t = In
+  { _in_users       :: [User]
+  , _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m ()
+view input = do
+  rec
+    categoryPage <- Reducer.reducer $ Reducer.In
+      { Reducer._in_page         = page
+      , Reducer._in_addCategory    = R.leftmost [ headerAddCategory, tableAddCategory ]
+      , Reducer._in_editCategory   = editCategory
+      , Reducer._in_deleteCategory = deleteCategory
+      }
+
+    let eventFromResult :: forall a. ((Event t (), Table.Out t, Pages.Out t) -> Event t a) -> m (Event t a)
+        eventFromResult op = ReflexUtil.flatten $ (Maybe.fromMaybe R.never . fmap op) <$> result
+
+    page <- eventFromResult $ Pages._out_newPage . (\(_, _, c) -> c)
+    headerAddCategory <- eventFromResult $ (\(a, _, _) -> a)
+    tableAddCategory <- eventFromResult $ Table._out_add . (\(_, b, _) -> b)
+    editCategory <- eventFromResult $ Table._out_edit . (\(_, b, _) -> b)
+    deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
+
+    result <- Loadable.viewShowValueWhileLoading categoryPage $
+      \(CategoryPage page categories count) -> do
+        header <- headerView
+
+        table <- Table.view $ Table.In
+          { Table._in_currentUser = _in_currentUser input
+          , Table._in_currency = _in_currency input
+          , Table._in_categories = categories
+          , Table._in_users = _in_users input
+          }
+
+        pages <- Pages.view $ Pages.In
+          { Pages._in_total = R.constDyn count
+          , Pages._in_perPage = Reducer.perPage
+          , Pages._in_page = page
+          }
+
+        return (header, table, pages)
+
+  return ()
+
+headerView :: forall t m. MonadWidget t m => m (Event t ())
+headerView =
+  R.divClass "titleButton" $ do
+    R.el "h1" $
+      R.text $
+        Msg.get Msg.Category_Title
+
+    addCategory <- Button._out_clic <$>
+      (Button.view . Button.defaultIn . R.text $
+        Msg.get Msg.Category_Add)
+
+    addCategory <- Modal.view $ Modal.In
+      { Modal._in_show    = addCategory
+      , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
+      }
+
+    return addCategory
diff --git a/client/src/View/Category/Form.hs b/client/src/View/Category/Form.hs
new file mode 100644
index 0000000..d91fc2e
--- /dev/null
+++ b/client/src/View/Category/Form.hs
@@ -0,0 +1,117 @@
+module View.Category.Form
+  ( view
+  , In(..)
+  , Operation(..)
+  ) where
+
+import           Control.Monad.IO.Class     (liftIO)
+import           Data.Aeson                 (Value)
+import qualified Data.Aeson                 as Aeson
+import qualified Data.Maybe                 as Maybe
+import           Data.Text                  (Text)
+import qualified Data.Text                  as T
+import qualified Data.Time.Calendar         as Calendar
+import qualified Data.Time.Clock            as Time
+import           Data.Validation            (Validation)
+import qualified Data.Validation            as V
+import           Reflex.Dom                 (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom                 as R
+
+import           Common.Model               (Category (..),
+                                             CreateCategoryForm (..),
+                                             EditCategoryForm (..))
+import qualified Common.Msg                 as Msg
+import qualified Common.Util.Time           as TimeUtil
+import qualified Common.Validation.Category as CategoryValidation
+import qualified Component.Input            as Input
+import qualified Component.Modal            as Modal
+import qualified Component.ModalForm        as ModalForm
+import qualified Util.Ajax                  as Ajax
+
+data In = In
+  { _in_operation :: Operation
+  }
+
+data Operation
+  = New
+  | Clone Category
+  | Edit Category
+
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m
+view input cancel = do
+
+  rec
+    let reset = R.leftmost
+          [ "" <$ ModalForm._out_cancel modalForm
+          , "" <$ ModalForm._out_validate modalForm
+          , "" <$ cancel
+          ]
+
+    modalForm <- ModalForm.view $ ModalForm.In
+      { ModalForm._in_headerLabel = headerLabel
+      , ModalForm._in_ajax        = ajax "/api/category"
+      , ModalForm._in_form        = form reset (ModalForm._out_confirm modalForm)
+      }
+
+  return (ModalForm._out_hide modalForm, ModalForm._out_validate modalForm)
+
+  where
+
+    form
+      :: Event t String
+      -> Event t ()
+      -> m (Dynamic t (Validation Text Value))
+    form reset confirm = do
+      name <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Category_Name
+          , Input._in_initialValue = name
+          , Input._in_validation = CategoryValidation.name
+          })
+        (name <$ reset)
+        confirm)
+
+      color <- Input._out_raw <$> (Input.view
+        (Input.defaultIn
+          { Input._in_label = Msg.get Msg.Category_Color
+          , Input._in_initialValue = color
+          , Input._in_inputType = "color"
+          , Input._in_hasResetButton = False
+          , Input._in_validation = CategoryValidation.color
+          })
+        (color <$ reset)
+        confirm)
+
+      return $ do
+        n <- name
+        c <- color
+        return . V.Success $ mkPayload n c
+
+    op = _in_operation input
+
+    name =
+      case op of
+        New     -> ""
+        Clone c -> _category_name c
+        Edit c  -> _category_name c
+
+    color =
+      case op of
+        New     -> ""
+        Clone c -> _category_color c
+        Edit c  -> _category_color c
+
+    ajax =
+      case op of
+        Edit _ -> Ajax.put
+        _      -> Ajax.post
+
+    headerLabel =
+      case op of
+        Edit _ -> Msg.get Msg.Category_Edit
+        _      -> Msg.get Msg.Category_Add
+
+    mkPayload =
+      case op of
+        Edit i -> \a b -> Aeson.toJSON $ EditCategoryForm (_category_id i) a b
+        _      -> \a b -> Aeson.toJSON $ CreateCategoryForm a b
diff --git a/client/src/View/Category/Reducer.hs b/client/src/View/Category/Reducer.hs
new file mode 100644
index 0000000..5ad0ddb
--- /dev/null
+++ b/client/src/View/Category/Reducer.hs
@@ -0,0 +1,59 @@
+module View.Category.Reducer
+  ( perPage
+  , reducer
+  , In(..)
+  ) where
+
+import           Data.Text    (Text)
+import qualified Data.Text    as T
+import           Reflex.Dom   (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom   as R
+
+import           Common.Model (CategoryPage)
+
+import           Loadable     (Loadable (..))
+import qualified Loadable     as Loadable
+import qualified Util.Ajax    as AjaxUtil
+import qualified Util.Either  as EitherUtil
+
+perPage :: Int
+perPage = 7
+
+data In t a b c = In
+  { _in_page           :: Event t Int
+  , _in_addCategory    :: Event t a
+  , _in_editCategory   :: Event t b
+  , _in_deleteCategory :: Event t c
+  }
+
+reducer :: forall t m a b c. MonadWidget t m => In t a b c -> m (Dynamic t (Loadable CategoryPage))
+reducer input = do
+
+  postBuild <- R.getPostBuild
+
+  currentPage <- R.holdDyn 1 (_in_page input)
+
+  let loadPage =
+        R.leftmost
+          [ 1 <$ postBuild
+          , _in_page input
+          , 1 <$ _in_addCategory input
+          , R.tag (R.current currentPage) (_in_editCategory input)
+          , R.tag (R.current currentPage) (_in_deleteCategory input)
+          ]
+
+  getResult <- AjaxUtil.get $ fmap pageUrl loadPage
+
+  R.holdDyn
+    Loading
+    (R.leftmost
+      [ Loading <$ loadPage
+      , Loadable.fromEither <$> getResult
+      ])
+
+  where
+    pageUrl p =
+      "api/categories?page="
+      <> (T.pack . show $ p)
+      <> "&perPage="
+      <> (T.pack . show $ perPage)
diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs
new file mode 100644
index 0000000..fbe76e9
--- /dev/null
+++ b/client/src/View/Category/Table.hs
@@ -0,0 +1,91 @@
+module View.Category.Table
+  ( view
+  , In(..)
+  , Out(..)
+  ) where
+
+import qualified Data.Maybe              as Maybe
+import           Data.Text               (Text)
+import qualified Data.Text               as T
+import           Reflex.Dom              (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom              as R
+
+import           Common.Model            (Category (..), Currency, User (..),
+                                          UserId)
+import qualified Common.Model            as CM
+import qualified Common.Msg              as Msg
+import qualified Common.View.Format      as Format
+
+import qualified Component.ConfirmDialog as ConfirmDialog
+import qualified Component.Table         as Table
+import qualified Component.Tag           as Tag
+import qualified Util.Ajax               as Ajax
+import qualified Util.Either             as EitherUtil
+import qualified View.Category.Form      as Form
+
+data In t = In
+  { _in_currentUser :: UserId
+  , _in_currency    :: Currency
+  , _in_categories  :: [Category]
+  , _in_users       :: [User]
+  }
+
+data Out t = Out
+  { _out_add    :: Event t ()
+  , _out_edit   :: Event t ()
+  , _out_delete :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
+
+  table <- Table.view $ Table.In
+    { Table._in_headerLabel = headerLabel
+    , Table._in_rows = _in_categories input
+    , Table._in_cell = cell (_in_users input) (_in_currency input)
+    , Table._in_cloneModal = \category ->
+      Form.view $ Form.In
+        { Form._in_operation = Form.Clone category
+        }
+    , Table._in_editModal = \category ->
+      Form.view $ Form.In
+        { Form._in_operation = Form.Edit category
+        }
+    , Table._in_deleteModal = \category ->
+      ConfirmDialog.view $ ConfirmDialog.In
+        { ConfirmDialog._in_header  = Msg.get Msg.Category_DeleteConfirm
+        , ConfirmDialog._in_confirm = \e -> do
+          res <- Ajax.delete
+            (R.constDyn $ T.concat ["/api/category/", T.pack . show $ _category_id category])
+            e
+          return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+        }
+    , Table._in_isOwner = const True
+    }
+
+  return $ Out
+    { _out_add = Table._out_add table
+    , _out_edit = Table._out_edit table
+    , _out_delete = Table._out_delete table
+    }
+
+data Header
+  = NameHeader
+  | ColorHeader
+  deriving (Eq, Show, Bounded, Enum)
+
+headerLabel :: Header -> Text
+headerLabel NameHeader  = Msg.get Msg.Category_Name
+headerLabel ColorHeader = Msg.get Msg.Category_Color
+
+cell :: forall t m. MonadWidget t m => [User] -> Currency -> Header -> Category -> m ()
+cell users currency header category =
+  case header of
+    NameHeader ->
+      R.text $ _category_name category
+
+    ColorHeader ->
+      Tag.view $ Tag.In
+        { Tag._in_text = _category_name category
+        , Tag._in_color = _category_color category
+        }
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 3f58dd5..5910f52 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -63,6 +63,11 @@ links route = do
     (R.ffor route (attrs IncomeRoute))
     (Msg.get Msg.Income_Title)
 
+  Link.view
+    "/category"
+    (R.ffor route (attrs CategoryRoute))
+    (Msg.get Msg.Category_Title)
+
   where
     attrs linkRoute currentRoute =
       M.singleton "class" $
diff --git a/client/src/View/Income/Form.hs b/client/src/View/Income/Form.hs
index ff6e55e..59f6a0d 100644
--- a/client/src/View/Income/Form.hs
+++ b/client/src/View/Income/Form.hs
@@ -36,7 +36,7 @@ data Operation
   | Clone Income
   | Edit Income
 
-view :: forall t m a. MonadWidget t m => In -> Modal.Content t m Income
+view :: forall t m a. MonadWidget t m => In -> Modal.Content t m
 view input cancel = do
 
   rec
diff --git a/client/src/View/Income/Header.hs b/client/src/View/Income/Header.hs
index 9e1c5b6..a26e16a 100644
--- a/client/src/View/Income/Header.hs
+++ b/client/src/View/Income/Header.hs
@@ -21,7 +21,6 @@ import qualified Common.View.Format     as Format
 import qualified Component.Button       as Button
 import qualified Component.Modal        as Modal
 import qualified View.Income.Form       as Form
-import           View.Income.Init       (Init (..))
 
 data In t = In
   { _in_users    :: [User]
@@ -30,7 +29,7 @@ data In t = In
   }
 
 data Out t = Out
-  { _out_add :: Event t Income
+  { _out_add :: Event t ()
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
diff --git a/client/src/View/Income/Income.hs b/client/src/View/Income/Income.hs
index e83ba80..7be8091 100644
--- a/client/src/View/Income/Income.hs
+++ b/client/src/View/Income/Income.hs
@@ -21,7 +21,6 @@ import qualified Util.Ajax           as AjaxUtil
 import qualified Util.Reflex         as ReflexUtil
 import qualified Util.Reflex         as ReflexUtil
 import qualified View.Income.Header  as Header
-import           View.Income.Init    (Init (..))
 import qualified View.Income.Reducer as Reducer
 import qualified View.Income.Table   as Table
 
diff --git a/client/src/View/Income/Init.hs b/client/src/View/Income/Init.hs
deleted file mode 100644
index 4f3ef99..0000000
--- a/client/src/View/Income/Init.hs
+++ /dev/null
@@ -1,11 +0,0 @@
-module View.Income.Init
-  ( Init(..)
-  ) where
-
-import           Common.Model (Income, Payment, User)
-
-data Init = Init
-  { _init_users    :: [User]
-  , _init_incomes  :: [Income]
-  , _init_payments :: [Payment]
-  } deriving (Show)
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index c623acb..c7f172b 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -4,7 +4,6 @@ module View.Income.Table
   , Out(..)
   ) where
 
-import qualified Data.List               as L
 import qualified Data.Maybe              as Maybe
 import           Data.Text               (Text)
 import qualified Data.Text               as T
@@ -31,9 +30,9 @@ data In t = In
   }
 
 data Out t = Out
-  { _out_add    :: Event t Income
-  , _out_edit   :: Event t Income
-  , _out_delete :: Event t Income
+  { _out_add    :: Event t ()
+  , _out_edit   :: Event t ()
+  , _out_delete :: Event t ()
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
@@ -41,7 +40,7 @@ view input = do
 
   table <- Table.view $ Table.In
     { Table._in_headerLabel = headerLabel
-    , Table._in_rows = reverse . L.sortOn _income_date $ _in_incomes input
+    , Table._in_rows = _in_incomes input
     , Table._in_cell = cell (_in_users input) (_in_currency input)
     , Table._in_cloneModal = \income ->
       Form.view $ Form.In
@@ -58,7 +57,7 @@ view input = do
           res <- Ajax.delete
             (R.constDyn $ T.concat ["/api/income/", T.pack . show $ _income_id income])
             e
-          return $ income <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+          return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
     , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId
     }
diff --git a/client/src/View/Payment/Form.hs b/client/src/View/Payment/Form.hs
index 064b5b3..6c31fad 100644
--- a/client/src/View/Payment/Form.hs
+++ b/client/src/View/Payment/Form.hs
@@ -51,7 +51,7 @@ data Operation t
   | Clone Payment
   | Edit Payment
 
-view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m Payment
+view :: forall t m a. MonadWidget t m => In t -> Modal.Content t m
 view input cancel = do
   rec
     let reset = R.leftmost
diff --git a/client/src/View/Payment/HeaderForm.hs b/client/src/View/Payment/HeaderForm.hs
index 0ee0cd3..1915841 100644
--- a/client/src/View/Payment/HeaderForm.hs
+++ b/client/src/View/Payment/HeaderForm.hs
@@ -29,7 +29,7 @@ data In t = In
 data Out t = Out
   { _out_search     :: Event t Text
   , _out_frequency  :: Event t Frequency
-  , _out_addPayment :: Event t Payment
+  , _out_addPayment :: Event t ()
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
diff --git a/client/src/View/Payment/Payment.hs b/client/src/View/Payment/Payment.hs
index 8d0fee1..26444d7 100644
--- a/client/src/View/Payment/Payment.hs
+++ b/client/src/View/Payment/Payment.hs
@@ -36,7 +36,7 @@ data In t = In
 view :: forall t m. MonadWidget t m => In t -> m ()
 view input = do
 
-  categories <- AjaxUtil.getNow "api/categories"
+  categories <- AjaxUtil.getNow "api/allCategories"
 
   R.dyn . R.ffor categories . Loadable.viewHideValueWhileLoading $ \categories -> do
 
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index f9215bc..6744d3a 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -21,6 +21,7 @@ import qualified Common.View.Format      as Format
 
 import qualified Component.ConfirmDialog as ConfirmDialog
 import qualified Component.Table         as Table
+import qualified Component.Tag           as Tag
 import qualified Util.Ajax               as Ajax
 import qualified Util.Either             as EitherUtil
 import qualified View.Payment.Form       as Form
@@ -35,9 +36,9 @@ data In t = In
   }
 
 data Out t = Out
-  { _out_add    :: Event t Payment
-  , _out_edit   :: Event t Payment
-  , _out_delete :: Event t Payment
+  { _out_add    :: Event t ()
+  , _out_edit   :: Event t ()
+  , _out_delete :: Event t ()
   }
 
 view :: forall t m. MonadWidget t m => In t -> m (Out t)
@@ -45,7 +46,7 @@ view input = do
 
   table <- Table.view $ Table.In
     { Table._in_headerLabel = headerLabel (_in_frequency input)
-    , Table._in_rows = reverse . L.sortOn _payment_date $ _in_payments input
+    , Table._in_rows = _in_payments input
     , Table._in_cell =
       cell
         (_in_users input)
@@ -71,7 +72,7 @@ view input = do
           res <- Ajax.delete
             (R.constDyn $ T.concat ["/api/payment/", T.pack . show $ _payment_id payment])
             e
-          return $ payment <$ R.fmapMaybe EitherUtil.eitherToMaybe res
+          return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
     , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user
     }
@@ -122,21 +123,12 @@ cell users categories frequency currency header payment =
       let
         category =
           L.find ((== (_payment_category payment)) . _category_id) categories
-
-        attrs =
-          case category of
-            Just c ->
-              M.fromList
-                [ ("class", "tag")
-                , ("style", T.concat [ "background-color: ", _category_color c ])
-                ]
-
-            Nothing ->
-              M.singleton "display" "none"
       in
-        R.elAttr "span" attrs $
-          R.text $
-            Maybe.fromMaybe "" (_category_name <$> category)
+        Maybe.fromMaybe R.blank . flip fmap category $ \c ->
+          Tag.view $ Tag.In
+            { Tag._in_text = _category_name c
+            , Tag._in_color = _category_color c
+            }
 
     DateHeader ->
       if frequency == Punctual then
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index a589fc3..0a3b576 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -50,7 +50,7 @@ view signInMessage =
         let form = SignInForm <$> Input._out_raw input
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.post "/api/askSignIn")
+          (Ajax.postAndParseResult "/api/askSignIn")
           (ValidationUtil.fireMaybe
             ((\f -> f <$ SignInValidation.signIn f) <$> form)
             validate)
-- 
cgit v1.2.3


From da2a0c13aa89705c65fdb9df2f496fb4eea29654 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 4 Jan 2020 19:22:45 +0100
Subject: Allow to remove only unused categories

---
 client/src/Component/Input.hs        |  2 +-
 client/src/Component/Table.hs        |  9 ++++-----
 client/src/View/Category/Category.hs | 34 ++++++++++++++++++----------------
 client/src/View/Category/Table.hs    | 16 +++++++++-------
 client/src/View/Income/Table.hs      |  3 ++-
 client/src/View/Payment/Table.hs     |  3 ++-
 6 files changed, 36 insertions(+), 31 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 37020da..bcff377 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -57,7 +57,7 @@ view input reset validate = do
           ]
 
         inputAttr = R.ffor value (\v ->
-          if T.null v && _in_inputType input /= "date"
+          if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color"
             then M.empty
             else M.singleton "class" "filled")
 
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index f82cfa6..1482f91 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -21,7 +21,8 @@ data In m t h r = In
   , _in_cloneModal  :: r -> Modal.Content t m
   , _in_editModal   :: r -> Modal.Content t m
   , _in_deleteModal :: r -> Modal.Content t m
-  , _in_isOwner     :: r -> Bool
+  , _in_canEdit     :: r -> Bool
+  , _in_canDelete   :: r -> Bool
   }
 
 data Out t = Out
@@ -62,8 +63,6 @@ view input =
                 , Modal._in_content = _in_cloneModal input row
                 }
 
-            let isOwner = _in_isOwner input row
-
             let visibleIf cond =
                   R.elAttr
                     "div"
@@ -71,7 +70,7 @@ view input =
 
             editButton <-
               R.divClass "cell button" $
-                visibleIf isOwner $
+                visibleIf (_in_canEdit input row) $
                   Button._out_clic <$> (Button.view $
                     Button.defaultIn Icon.edit)
 
@@ -83,7 +82,7 @@ view input =
 
             deleteButton <-
               R.divClass "cell button" $
-                visibleIf isOwner $
+                visibleIf (_in_canDelete input row) $
                   Button._out_clic <$> (Button.view $
                     Button.defaultIn Icon.delete)
 
diff --git a/client/src/View/Category/Category.hs b/client/src/View/Category/Category.hs
index 77a331a..5b41bb6 100644
--- a/client/src/View/Category/Category.hs
+++ b/client/src/View/Category/Category.hs
@@ -53,13 +53,14 @@ view input = do
     deleteCategory <- eventFromResult $ Table._out_delete . (\(_, b, _) -> b)
 
     result <- Loadable.viewShowValueWhileLoading categoryPage $
-      \(CategoryPage page categories count) -> do
+      \(CategoryPage page categories usedCategories count) -> do
         header <- headerView
 
         table <- Table.view $ Table.In
           { Table._in_currentUser = _in_currentUser input
           , Table._in_currency = _in_currency input
           , Table._in_categories = categories
+          , Table._in_usedCategories = usedCategories
           , Table._in_users = _in_users input
           }
 
@@ -75,18 +76,19 @@ view input = do
 
 headerView :: forall t m. MonadWidget t m => m (Event t ())
 headerView =
-  R.divClass "titleButton" $ do
-    R.el "h1" $
-      R.text $
-        Msg.get Msg.Category_Title
-
-    addCategory <- Button._out_clic <$>
-      (Button.view . Button.defaultIn . R.text $
-        Msg.get Msg.Category_Add)
-
-    addCategory <- Modal.view $ Modal.In
-      { Modal._in_show    = addCategory
-      , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
-      }
-
-    return addCategory
+  R.divClass "withMargin" $
+    R.divClass "titleButton" $ do
+      R.el "h1" $
+        R.text $
+          Msg.get Msg.Category_Title
+
+      addCategory <- Button._out_clic <$>
+        (Button.view . Button.defaultIn . R.text $
+          Msg.get Msg.Category_Add)
+
+      addCategory <- Modal.view $ Modal.In
+        { Modal._in_show    = addCategory
+        , Modal._in_content = Form.view $ Form.In { Form._in_operation = Form.New }
+        }
+
+      return addCategory
diff --git a/client/src/View/Category/Table.hs b/client/src/View/Category/Table.hs
index fbe76e9..90d013d 100644
--- a/client/src/View/Category/Table.hs
+++ b/client/src/View/Category/Table.hs
@@ -10,8 +10,8 @@ import qualified Data.Text               as T
 import           Reflex.Dom              (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom              as R
 
-import           Common.Model            (Category (..), Currency, User (..),
-                                          UserId)
+import           Common.Model            (Category (..), CategoryId, Currency,
+                                          User (..), UserId)
 import qualified Common.Model            as CM
 import qualified Common.Msg              as Msg
 import qualified Common.View.Format      as Format
@@ -24,10 +24,11 @@ import qualified Util.Either             as EitherUtil
 import qualified View.Category.Form      as Form
 
 data In t = In
-  { _in_currentUser :: UserId
-  , _in_currency    :: Currency
-  , _in_categories  :: [Category]
-  , _in_users       :: [User]
+  { _in_currentUser    :: UserId
+  , _in_currency       :: Currency
+  , _in_categories     :: [Category]
+  , _in_usedCategories :: [CategoryId]
+  , _in_users          :: [User]
   }
 
 data Out t = Out
@@ -60,7 +61,8 @@ view input = do
             e
           return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
-    , Table._in_isOwner = const True
+    , Table._in_canEdit = const True
+    , Table._in_canDelete = not . flip elem (_in_usedCategories input) . _category_id
     }
 
   return $ Out
diff --git a/client/src/View/Income/Table.hs b/client/src/View/Income/Table.hs
index c7f172b..7b7940d 100644
--- a/client/src/View/Income/Table.hs
+++ b/client/src/View/Income/Table.hs
@@ -59,7 +59,8 @@ view input = do
             e
           return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
-    , Table._in_isOwner = (== (_in_currentUser input)) . _income_userId
+    , Table._in_canEdit = (== (_in_currentUser input)) . _income_userId
+    , Table._in_canDelete = (== (_in_currentUser input)) . _income_userId
     }
 
   return $ Out
diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs
index 6744d3a..bfa0fb9 100644
--- a/client/src/View/Payment/Table.hs
+++ b/client/src/View/Payment/Table.hs
@@ -74,7 +74,8 @@ view input = do
             e
           return $ () <$ R.fmapMaybe EitherUtil.eitherToMaybe res
         }
-    , Table._in_isOwner = (== (_in_currentUser input)) . _payment_user
+    , Table._in_canEdit = (== (_in_currentUser input)) . _payment_user
+    , Table._in_canDelete = (== (_in_currentUser input)) . _payment_user
     }
 
   return $ Out
-- 
cgit v1.2.3


From cdb0ae1aeb22d7d7c36acb9d580f3723aa469829 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sat, 4 Jan 2020 19:26:08 +0100
Subject: Go to page 1 when switching the search frequency

---
 client/src/View/Payment/Reducer.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'client/src')

diff --git a/client/src/View/Payment/Reducer.hs b/client/src/View/Payment/Reducer.hs
index 7468097..3fe59b2 100644
--- a/client/src/View/Payment/Reducer.hs
+++ b/client/src/View/Payment/Reducer.hs
@@ -68,7 +68,7 @@ reducer input = do
         Just $ params { _params_search = search, _params_page = _params_page initParams }
 
       Frequency frequency ->
-        Just $ params { _params_frequency = frequency }
+        Just $ params { _params_frequency = frequency, _params_page = _params_page initParams }
 
       ResetSearch   ->
         Just $ initParams { _params_frequency = _params_frequency params }
-- 
cgit v1.2.3


From af8353c6164aaaaa836bfed181f883ac86bb76a5 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 19 Jan 2020 14:03:31 +0100
Subject: Sign in with email and password

---
 client/src/Component/Button.hs |  2 +-
 client/src/Main.hs             | 10 +++---
 client/src/Util/Validation.hs  | 11 -------
 client/src/View/App.hs         | 61 +++++++++++++++++-------------------
 client/src/View/Header.hs      | 52 +++++++++++++++----------------
 client/src/View/SignIn.hs      | 71 ++++++++++++++++++++++++------------------
 6 files changed, 100 insertions(+), 107 deletions(-)

(limited to 'client/src')

diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index 6faecef..153a61b 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -22,7 +22,7 @@ data In t m = In
   , _in_submit   :: Bool
   }
 
-defaultIn :: MonadWidget t m => m () -> In t m
+defaultIn :: forall t m. MonadWidget t m => m () -> In t m
 defaultIn content = In
   { _in_class    = R.constDyn ""
   , _in_content  = content
diff --git a/client/src/Main.hs b/client/src/Main.hs
index d6f89cd..c71b0f0 100644
--- a/client/src/Main.hs
+++ b/client/src/Main.hs
@@ -14,7 +14,7 @@ import           JSDOM.Types                          (HTMLElement (..), JSM,
 import qualified JSDOM.Types                          as Dom
 import           Prelude                              hiding (error, init)
 
-import           Common.Model                         (InitResult (InitError))
+import           Common.Model                         (Init)
 import qualified Common.Msg                           as Msg
 
 import qualified View.App                             as App
@@ -24,7 +24,7 @@ main = do
   initResult <- readInit
   App.widget initResult
 
-readInit :: JSM InitResult
+readInit :: JSM (Maybe Init)
 readInit = do
   document <- Dom.currentDocumentUnchecked
   initNode <- Dom.getElementById document ("init" :: JSString)
@@ -34,8 +34,6 @@ readInit = do
       text <- Dom.textFromJSString <$> Dom.getInnerText (Dom.uncheckedCastTo HTMLElement node)
       return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
         Just init -> init
-        Nothing   -> initParseError
+        Nothing   -> Nothing
     _ ->
-      return initParseError
-
-  where initParseError = InitError $ Msg.get Msg.SignIn_ParseError
+      return Nothing
diff --git a/client/src/Util/Validation.hs b/client/src/Util/Validation.hs
index f9545a4..50f2468 100644
--- a/client/src/Util/Validation.hs
+++ b/client/src/Util/Validation.hs
@@ -3,7 +3,6 @@ module Util.Validation
   , toMaybe
   , maybeError
   , fireValidation
-  , fireMaybe
   ) where
 
 import           Control.Monad      (join)
@@ -35,13 +34,3 @@ fireValidation value validate =
   R.fmapMaybe
     (Validation.validation (const Nothing) Just)
     (R.tag (R.current value) validate)
-
-fireMaybe
-  :: forall t a b. Reflex t
-  => Dynamic t (Maybe a)
-  -> Event t b
-  -> Event t a
-fireMaybe value validate =
-  R.fmapMaybe
-    id
-    (R.tag (R.current value) validate)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index 460d499..b0b89fb 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -4,14 +4,14 @@ module View.App
 
 import qualified Data.Text              as T
 import           Prelude                hiding (error, init)
-import           Reflex.Dom             (Dynamic, MonadWidget)
+import           Reflex.Dom             (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom             as R
 
-import           Common.Model           (Currency, Init (..), InitResult (..),
-                                         UserId)
+import           Common.Model           (Currency, Init (..), UserId)
 import qualified Common.Msg             as Msg
 
 import           Model.Route            (Route (..))
+import qualified Util.Reflex            as ReflexUtil
 import qualified Util.Router            as Router
 import qualified View.Category.Category as Category
 import qualified View.Header            as Header
@@ -20,43 +20,40 @@ import qualified View.NotFound          as NotFound
 import qualified View.Payment.Payment   as Payment
 import qualified View.SignIn            as SignIn
 
-widget :: InitResult -> IO ()
-widget initResult =
+widget :: Maybe Init -> IO ()
+widget init =
   R.mainWidget $ R.divClass "app" $ do
 
     route <- getRoute
 
-    header <- Header.view $ Header.In
-      { Header._in_initResult = initResult
-      , Header._in_isInitSuccess =
-        case initResult of
-          InitSuccess _ -> True
-          _             -> False
-      , Header._in_route = route
-      }
-
-    let signOut =
-          Header._out_signOut header
-
-        mainContent =
-          case initResult of
-            InitSuccess init ->
-              signedWidget init route
-
-            InitEmpty ->
-              SignIn.view SignIn.EmptyMessage
+    rec
+      header <- Header.view $ Header.In
+        { Header._in_init = initState
+        , Header._in_route = route
+        }
 
-            InitError error ->
-              SignIn.view (SignIn.ErrorMessage error)
+      initState <-
+        R.foldDyn
+          const
+          init
+          (R.leftmost $
+            [ initEvent
+            , Nothing <$ (Header._out_signOut header)
+            ])
 
-        signOutContent =
-          SignIn.view (SignIn.SuccessMessage $ Msg.get Msg.SignIn_DisconnectSuccess)
+      initEvent <-
+        (R.dyn . R.ffor initState $ \case
+          Nothing -> do
+            signIn <- SignIn.view
+            return (Just <$> SignIn._out_success signIn)
 
-    _ <- R.widgetHold (mainContent) (signOutContent <$ signOut)
+          Just i -> do
+            signedWidget i route
+            return R.never) >>= ReflexUtil.flatten
 
-    R.blank
+    return ()
 
-signedWidget :: MonadWidget t m => Init -> Dynamic t Route -> m ()
+signedWidget :: forall t m. MonadWidget t m => Init -> Dynamic t Route -> m ()
 signedWidget init route = do
   R.dyn . R.ffor route $ \case
     RootRoute ->
@@ -85,7 +82,7 @@ signedWidget init route = do
 
   return ()
 
-getRoute :: MonadWidget t m => m (Dynamic t Route)
+getRoute :: forall t m. MonadWidget t m => m (Dynamic t Route)
 getRoute = do
   r <- Router.partialPathRoute "" . R.switchPromptlyDyn =<< R.holdDyn R.never R.never
   return . R.ffor r $ \case
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index 5910f52..f91c408 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -6,6 +6,7 @@ module View.Header
 
 import           Data.Map         (Map)
 import qualified Data.Map         as M
+import qualified Data.Maybe       as Maybe
 import           Data.Text        (Text)
 import qualified Data.Text        as T
 import           Data.Time        (NominalDiffTime)
@@ -13,7 +14,7 @@ import           Prelude          hiding (error, init)
 import           Reflex.Dom       (Dynamic, Event, MonadWidget)
 import qualified Reflex.Dom       as R
 
-import           Common.Model     (Init (..), InitResult (..), User (..))
+import           Common.Model     (Init (..), User (..))
 import qualified Common.Model     as CM
 import qualified Common.Msg       as Msg
 import qualified Component.Button as Button
@@ -24,9 +25,8 @@ import qualified Util.Reflex      as ReflexUtil
 import qualified View.Icon        as Icon
 
 data In t = In
-  { _in_initResult    :: InitResult
-  , _in_isInitSuccess :: Bool
-  , _in_route         :: Dynamic t Route
+  { _in_init  :: Dynamic t (Maybe Init)
+  , _in_route :: Dynamic t Route
   }
 
 data Out t = Out
@@ -40,12 +40,11 @@ view input =
     R.divClass "title" $
       R.text $ Msg.get Msg.App_Title
 
+    let showLinks = Maybe.isJust <$> _in_init input
+
     signOut <- R.el "div" $ do
-      rec
-        showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut)
-        ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
-        signOut <- nameSignOut $ _in_initResult input
-      return signOut
+      ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
+      (R.dyn $ nameSignOut <$> _in_init input) >>= ReflexUtil.flatten
 
     return $ Out
       { _out_signOut = signOut
@@ -76,23 +75,24 @@ links route = do
           , ("current", linkRoute == currentRoute)
           ]
 
-nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
-nameSignOut initResult = case initResult of
-  InitSuccess init -> do
-    rec
-      attr <- R.holdDyn
-        (M.singleton "class" "nameSignOut")
-        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
-
-      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
-        signOutButton
-
-    return signOut
-  _ ->
-    return R.never
+nameSignOut :: forall t m. MonadWidget t m => Maybe Init -> m (Event t ())
+nameSignOut init =
+  case init of
+    Just init -> do
+      rec
+        attr <- R.holdDyn
+          (M.singleton "class" "nameSignOut")
+          (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+        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
+          signOutButton
+
+      return signOut
+    _ ->
+      return R.never
 
 signOutButton :: forall t m. MonadWidget t m => m (Event t ())
 signOutButton = do
diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs
index 0a3b576..e68755f 100644
--- a/client/src/View/SignIn.hs
+++ b/client/src/View/SignIn.hs
@@ -1,17 +1,16 @@
 module View.SignIn
-  ( SignInMessage (..)
-  , view
+  ( view
+  , Out(..)
   ) where
 
 import qualified Data.Either              as Either
 import qualified Data.Maybe               as Maybe
 import           Data.Text                (Text)
-import           Data.Validation          (Validation)
-import           Prelude                  hiding (error)
+import qualified Data.Validation          as V
 import           Reflex.Dom               (Event, MonadWidget)
 import qualified Reflex.Dom               as R
 
-import           Common.Model             (SignInForm (SignInForm))
+import           Common.Model             (Init, SignInForm (SignInForm))
 import qualified Common.Msg               as Msg
 import qualified Common.Validation.SignIn as SignInValidation
 
@@ -22,22 +21,32 @@ import qualified Util.Ajax                as Ajax
 import qualified Util.Validation          as ValidationUtil
 import qualified Util.WaitFor             as WaitFor
 
-data SignInMessage =
-  SuccessMessage Text
-  | ErrorMessage Text
-  | EmptyMessage
+data Out t = Out
+  { _out_success       :: Event t Init
+  }
 
-view :: forall t m. MonadWidget t m => SignInMessage -> m ()
-view signInMessage =
-  R.divClass "signIn" $
+view :: forall t m. MonadWidget t m => m (Out t)
+view = do
+  signInResult <- R.divClass "signIn" $
     Form.view $ do
       rec
-        input <- (Input.view
+        let resetForm = ("" <$ R.ffilter Either.isRight signInResult)
+
+        email <- Input._out_raw <$> (Input.view
           (Input.defaultIn
             { Input._in_label = Msg.get Msg.SignIn_EmailLabel
             , Input._in_validation = SignInValidation.email
             })
-          ("" <$ R.ffilter Either.isRight signInResult)
+          resetForm
+          validate)
+
+        password <- Input._out_raw <$> (Input.view
+          (Input.defaultIn
+            { Input._in_label = Msg.get Msg.SignIn_PasswordLabel
+            , Input._in_validation = SignInValidation.password
+            , Input._in_inputType = "password"
+            })
+          resetForm
           validate)
 
         validate <- Button._out_clic <$> (Button.view $
@@ -47,27 +56,27 @@ view signInMessage =
             , Button._in_submit = True
             })
 
-        let form = SignInForm <$> Input._out_raw input
+        let form = do
+              e <- email
+              p <- password
+              return . V.Success $ SignInForm e p
 
         (signInResult, waiting) <- WaitFor.waitFor
-          (Ajax.postAndParseResult "/api/askSignIn")
-          (ValidationUtil.fireMaybe
-            ((\f -> f <$ SignInValidation.signIn f) <$> form)
-            validate)
+          (Ajax.postAndParseResult "/api/signIn")
+          (ValidationUtil.fireValidation form validate)
 
-      showSignInResult signInMessage signInResult
+      showSignInResult signInResult
 
-showSignInResult :: forall t m. MonadWidget t m => SignInMessage -> Event t (Either Text Text) -> m ()
-showSignInResult signInMessage signInResult = do
-  _ <- R.widgetHold (showInitResult signInMessage) $ R.ffor signInResult showResult
-  R.blank
+      return signInResult
 
-  where showInitResult (SuccessMessage success) = showSuccess success
-        showInitResult (ErrorMessage error)     = showError error
-        showInitResult EmptyMessage             = R.blank
+  return $ Out
+    { _out_success = R.filterRight signInResult
+    }
 
-        showResult (Left error)    = showError error
-        showResult (Right success) = showSuccess success
+showSignInResult :: forall t m. MonadWidget t m => Event t (Either Text Init) -> m ()
+showSignInResult signInResult = do
+  _ <- R.widgetHold R.blank $ showResult <$> signInResult
+  R.blank
 
-        showError = R.divClass "error" . R.text
-        showSuccess = R.divClass "success" . R.text
+  where showResult (Left error) = R.divClass "error" . R.text $ error
+        showResult (Right _)    = R.blank
-- 
cgit v1.2.3


From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 20 Jan 2020 19:47:23 +0100
Subject: Show payment stats

---
 client/src/Model/Route.hs                |   1 +
 client/src/View/App.hs                   |  43 +++++++------
 client/src/View/Header.hs                |   5 ++
 client/src/View/Statistics/Chart.hs      | 102 +++++++++++++++++++++++++++++++
 client/src/View/Statistics/Statistics.hs |  67 ++++++++++++++++++++
 5 files changed, 201 insertions(+), 17 deletions(-)
 create mode 100644 client/src/View/Statistics/Chart.hs
 create mode 100644 client/src/View/Statistics/Statistics.hs

(limited to 'client/src')

diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs
index 63e5d10..f92e9be 100644
--- a/client/src/Model/Route.hs
+++ b/client/src/Model/Route.hs
@@ -6,5 +6,6 @@ data Route
   = RootRoute
   | IncomeRoute
   | CategoryRoute
+  | StatisticsRoute
   | NotFoundRoute
   deriving (Eq, Show)
diff --git a/client/src/View/App.hs b/client/src/View/App.hs
index b0b89fb..71f0234 100644
--- a/client/src/View/App.hs
+++ b/client/src/View/App.hs
@@ -2,23 +2,24 @@ module View.App
   ( widget
   ) where
 
-import qualified Data.Text              as T
-import           Prelude                hiding (error, init)
-import           Reflex.Dom             (Dynamic, Event, MonadWidget)
-import qualified Reflex.Dom             as R
-
-import           Common.Model           (Currency, Init (..), UserId)
-import qualified Common.Msg             as Msg
-
-import           Model.Route            (Route (..))
-import qualified Util.Reflex            as ReflexUtil
-import qualified Util.Router            as Router
-import qualified View.Category.Category as Category
-import qualified View.Header            as Header
-import qualified View.Income.Income     as Income
-import qualified View.NotFound          as NotFound
-import qualified View.Payment.Payment   as Payment
-import qualified View.SignIn            as SignIn
+import qualified Data.Text                  as T
+import           Prelude                    hiding (error, init)
+import           Reflex.Dom                 (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom                 as R
+
+import           Common.Model               (Currency, Init (..), UserId)
+import qualified Common.Msg                 as Msg
+
+import           Model.Route                (Route (..))
+import qualified Util.Reflex                as ReflexUtil
+import qualified Util.Router                as Router
+import qualified View.Category.Category     as Category
+import qualified View.Header                as Header
+import qualified View.Income.Income         as Income
+import qualified View.NotFound              as NotFound
+import qualified View.Payment.Payment       as Payment
+import qualified View.SignIn                as SignIn
+import qualified View.Statistics.Statistics as Statistics
 
 widget :: Maybe Init -> IO ()
 widget init =
@@ -77,6 +78,11 @@ signedWidget init route = do
         , Category._in_users = _init_users init
         }
 
+    StatisticsRoute ->
+      Statistics.view $ Statistics.In
+        { Statistics._in_currency = _init_currency init
+        }
+
     NotFoundRoute ->
       NotFound.view
 
@@ -95,5 +101,8 @@ getRoute = do
     ["category"] ->
       CategoryRoute
 
+    ["statistics"] ->
+      StatisticsRoute
+
     _ ->
       NotFoundRoute
diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs
index f91c408..ff9f40a 100644
--- a/client/src/View/Header.hs
+++ b/client/src/View/Header.hs
@@ -67,6 +67,11 @@ links route = do
     (R.ffor route (attrs CategoryRoute))
     (Msg.get Msg.Category_Title)
 
+  Link.view
+    "/statistics"
+    (R.ffor route (attrs StatisticsRoute))
+    (Msg.get Msg.Statistics_Title)
+
   where
     attrs linkRoute currentRoute =
       M.singleton "class" $
diff --git a/client/src/View/Statistics/Chart.hs b/client/src/View/Statistics/Chart.hs
new file mode 100644
index 0000000..63df2a1
--- /dev/null
+++ b/client/src/View/Statistics/Chart.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP           #-}
+{-# LANGUAGE JavaScriptFFI #-}
+
+module View.Statistics.Chart
+  ( view
+  , In(..)
+  , Dataset(..)
+  ) where
+
+import qualified Control.Concurrent                as Concurrent
+import           Control.Monad                     (void)
+import           Control.Monad.IO.Class            (liftIO)
+import           Data.Aeson                        ((.=))
+import qualified Data.Aeson                        as AE
+import qualified Data.Map                          as M
+import           Data.Text                         (Text)
+import           Language.Javascript.JSaddle       (JSString, JSVal)
+import qualified Language.Javascript.JSaddle.Value as JSValue
+import           Reflex.Dom                        (MonadWidget)
+import qualified Reflex.Dom                        as R
+-- import GHCJS.Foreign.Callback
+
+
+#ifdef __GHCJS__
+foreign import javascript unsafe "new Chart(document.getElementById($1), $2);" drawChart :: JSString -> JSVal -> IO ()
+#else
+drawChart = error "drawChart: only available from JavaScript"
+#endif
+
+data In = In
+  { _in_title    :: Text
+  , _in_labels   :: [Text]
+  , _in_datasets :: [Dataset]
+  }
+
+data Dataset = Dataset
+  { _dataset_label :: Text
+  , _dataset_data  :: [Int]
+  , _dataset_color :: Text
+  }
+
+view :: forall t m. MonadWidget t m => In -> m ()
+view input = do
+  R.divClass "g-Chart" $
+    R.elAttr "canvas" (M.singleton "id" "chart") $
+      R.blank
+
+  liftIO $ Concurrent.forkIO $ do
+    Concurrent.threadDelay 500000
+    config <- JSValue.valMakeJSON (configToJson input)
+    drawChart "chart" config
+
+  return ()
+
+configToJson (In title labels datasets) =
+  AE.object
+    [ "type" .= AE.String "line"
+    , "data" .=
+      AE.object
+        [ "labels" .= labels
+        , "datasets" .= map datasetToJson datasets
+        ]
+    , "options" .=
+      AE.object
+        [ "responsive" .= True
+        , "title" .=
+          AE.object
+            [ "display" .= True
+            , "text" .= title
+            ]
+        , "tooltips" .=
+          AE.object
+            [ "mode" .= AE.String "nearest"
+            , "intersect" .= False
+            ]
+        , "hover" .=
+          AE.object
+            [ "mode" .= AE.String "nearest"
+            , "intersect" .= True
+            ]
+        , "scales" .=
+          AE.object
+            [ "yAxes" .=
+              [ [ AE.object
+                  [ "ticks" .=
+                    AE.object
+                      [ "beginAtZero" .= True ]
+                  ]
+                ]
+              ]
+            ]
+        ]
+      ]
+
+datasetToJson (Dataset label data_ color) =
+  AE.object
+    [ "label" .= label
+    , "data" .= data_
+    , "fill" .= False
+    , "backgroundColor" .= color
+    , "borderColor" .= color
+    ]
diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs
new file mode 100644
index 0000000..71f93d4
--- /dev/null
+++ b/client/src/View/Statistics/Statistics.hs
@@ -0,0 +1,67 @@
+module View.Statistics.Statistics
+  ( view
+  , In(..)
+  ) where
+
+import           Control.Monad         (void)
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+import qualified Data.Text             as T
+import           Data.Time.Calendar    (Day)
+import qualified Data.Time.Calendar    as Calendar
+import           Loadable              (Loadable)
+import qualified Loadable
+import           Reflex.Dom            (Dynamic, MonadWidget)
+import qualified Reflex.Dom            as R
+import qualified Util.Ajax             as AjaxUtil
+import qualified View.Statistics.Chart as Chart
+
+import           Common.Model          (Category (..), Currency, PaymentStats)
+import qualified Common.Msg            as Msg
+import qualified Common.View.Format    as Format
+
+data In = In
+  { _in_currency    :: Currency
+  }
+
+view :: forall t m. MonadWidget t m => In -> m ()
+view input = do
+
+  categories <- AjaxUtil.getNow "api/allCategories"
+  statistics <- AjaxUtil.getNow "api/statistics"
+  let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics
+
+  R.divClass "withMargin" $
+    R.divClass "titleButton" $
+      R.el "h1" $
+        R.text $ Msg.get Msg.Statistics_Title
+
+  void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $
+    stats (_in_currency input)
+
+stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m ()
+stats currency (categories, stats) =
+  Chart.view $ Chart.In
+    { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth)
+    , Chart._in_labels = map (Format.monthAndYear . fst) stats
+    , Chart._in_datasets =
+      Chart.Dataset
+        { Chart._dataset_label = Msg.get Msg.Statistics_Total
+        , Chart._dataset_data  = totalSeries
+        , Chart._dataset_color = "#555555"
+        } : (map categoryDataset categories)
+    }
+
+  where
+    averageEachMonth =
+      Format.price currency $ sum totalSeries `div` length stats
+
+    totalSeries =
+      map (sum . map snd . M.toList . snd) stats
+
+    categoryDataset category =
+      Chart.Dataset
+        { Chart._dataset_label = _category_name category
+        , Chart._dataset_data  = map (M.findWithDefault 0 (_category_id category) . snd) stats
+        , Chart._dataset_color = _category_color category
+        }
-- 
cgit v1.2.3


From 79e1d8b0099d61b580a499311f1714b1b7eb07b5 Mon Sep 17 00:00:00 2001
From: Joris
Date: Mon, 27 Jan 2020 22:07:18 +0100
Subject: Show total incom by month in statistics

---
 client/src/View/Statistics/Statistics.hs | 54 +++++++++++++++++++++-----------
 1 file changed, 36 insertions(+), 18 deletions(-)

(limited to 'client/src')

diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs
index 71f93d4..d931b2b 100644
--- a/client/src/View/Statistics/Statistics.hs
+++ b/client/src/View/Statistics/Statistics.hs
@@ -16,7 +16,8 @@ import qualified Reflex.Dom            as R
 import qualified Util.Ajax             as AjaxUtil
 import qualified View.Statistics.Chart as Chart
 
-import           Common.Model          (Category (..), Currency, PaymentStats)
+import           Common.Model          (Category (..), Currency, Income,
+                                        MonthStats (..), Stats, User (..))
 import qualified Common.Msg            as Msg
 import qualified Common.View.Format    as Format
 
@@ -27,41 +28,58 @@ data In = In
 view :: forall t m. MonadWidget t m => In -> m ()
 view input = do
 
+  users <- AjaxUtil.getNow "api/users"
   categories <- AjaxUtil.getNow "api/allCategories"
   statistics <- AjaxUtil.getNow "api/statistics"
-  let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics
+
+  let loadable = (\u c s -> (,,) <$> u <*> c <*> s) <$> users <*> categories <*> statistics
 
   R.divClass "withMargin" $
     R.divClass "titleButton" $
       R.el "h1" $
         R.text $ Msg.get Msg.Statistics_Title
 
-  void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $
+  void . R.dyn . R.ffor loadable . Loadable.viewHideValueWhileLoading $
     stats (_in_currency input)
 
-stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m ()
-stats currency (categories, stats) =
+stats :: forall t m. MonadWidget t m => Currency -> ([User], [Category], Stats) -> m ()
+stats currency (users, categories, stats) =
   Chart.view $ Chart.In
-    { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth)
-    , Chart._in_labels = map (Format.monthAndYear . fst) stats
-    , Chart._in_datasets =
-      Chart.Dataset
-        { Chart._dataset_label = Msg.get Msg.Statistics_Total
-        , Chart._dataset_data  = totalSeries
-        , Chart._dataset_color = "#555555"
-        } : (map categoryDataset categories)
+    { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averagePayment averageIncome)
+    , Chart._in_labels = map (Format.monthAndYear . _monthStats_start) stats
+    , Chart._in_datasets = totalIncomeDataset : totalPaymentDataset : (map categoryDataset categories)
     }
 
   where
-    averageEachMonth =
-      Format.price currency $ sum totalSeries `div` length stats
+    averageIncome =
+      Format.price currency $ sum  totalIncomes `div` length stats
+
+    totalIncomeDataset =
+      Chart.Dataset
+        { Chart._dataset_label = Msg.get Msg.Statistics_TotalIncomes
+        , Chart._dataset_data  = totalIncomes
+        , Chart._dataset_color = "#222222"
+        }
+
+    totalIncomes =
+      map (sum . map snd . M.toList . _monthStats_incomeByUser) stats
+
+    averagePayment =
+      Format.price currency $ sum totalPayments `div` length stats
+
+    totalPaymentDataset =
+      Chart.Dataset
+        { Chart._dataset_label = Msg.get Msg.Statistics_TotalPayments
+        , Chart._dataset_data  = totalPayments
+        , Chart._dataset_color = "#555555"
+        }
 
-    totalSeries =
-      map (sum . map snd . M.toList . snd) stats
+    totalPayments =
+      map (sum . map snd . M.toList . _monthStats_paymentsByCategory) stats
 
     categoryDataset category =
       Chart.Dataset
         { Chart._dataset_label = _category_name category
-        , Chart._dataset_data  = map (M.findWithDefault 0 (_category_id category) . snd) stats
+        , Chart._dataset_data  = map (M.findWithDefault 0 (_category_id category) . _monthStats_paymentsByCategory) stats
         , Chart._dataset_color = _category_color category
         }
-- 
cgit v1.2.3