Add modal component

6 files changed, 127 insertions, 65 deletions

diff --git a/client/client.cabal b/client/client.cabal
index 02a7549..1064e7d 100644
--- a/client/client.cabal
+++ b/client/client.cabal
@@ -34,6 +34,7 @@ Executable client
   other-modules:
     Component.Button
     Component.Input
+    Component.Modal
     Icon
     Util.List
     View.App
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)