Add modal component

1 files changed, 80 insertions, 50 deletions

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)