diff options
Diffstat (limited to 'client/src/View')
| -rw-r--r-- | client/src/View/App.hs | 23 | ||||
| -rw-r--r-- | client/src/View/Header.hs | 27 | ||||
| -rw-r--r-- | client/src/View/Payment.hs | 29 | ||||
| -rw-r--r-- | client/src/View/Payment/Pages.hs | 57 | ||||
| -rw-r--r-- | client/src/View/Payment/Table.hs | 102 | ||||
| -rw-r--r-- | client/src/View/SignIn.hs | 36 |
6 files changed, 148 insertions, 126 deletions
diff --git a/client/src/View/App.hs b/client/src/View/App.hs index 1466811..442fa3e 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.App ( widget ) where -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import Prelude hiding (error, init) +import qualified Reflex.Dom as R -import Common.Model (InitResult(..)) -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key +import Common.Model (InitResult (..)) -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn +import View.Header (HeaderIn (..)) +import qualified View.Header as Header +import View.Payment (PaymentIn (..)) +import qualified View.Payment as Payment +import qualified View.SignIn as SignIn widget :: InitResult -> IO () widget initResult = diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index 705e054..711ba80 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Header ( view @@ -8,19 +7,19 @@ module View.Header , HeaderOut(..) ) where -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) +import qualified Data.Map as M +import Data.Time (NominalDiffTime) +import Prelude hiding (error, init) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model as CM +import Common.Model (Init (..), InitResult (..), User (..)) +import qualified Common.Model as CM -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component +import Component.Button (ButtonIn (..)) +import qualified Component.Button as Component import qualified Icon data HeaderIn = HeaderIn @@ -55,7 +54,7 @@ nameSignOut initResult = case initResult of signOut <- R.elDynAttr "nameSignOut" attr $ do case CM.findUser (_init_currentUser init) (_init_users init) of Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank + Nothing -> R.blank signOutButton return signOut diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index d1430c9..f70c8cd 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment ( widget @@ -8,14 +7,14 @@ module View.Payment , PaymentOut(..) ) where -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Init(..)) +import Common.Model (Init (..)) -import View.Payment.Pages (PagesIn(..)) +import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages -import View.Payment.Table (TableIn(..)) +import View.Payment.Table (TableIn (..)) import qualified View.Payment.Table as Table data PaymentIn = PaymentIn @@ -29,10 +28,12 @@ data PaymentOut = PaymentOut widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - _ <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn - } + rec + _ <- Table.widget $ TableIn + { _tableIn_init = _paymentIn_init paymentIn + , _tableIn_currentPage = _pagesOut_currentPage pagesOut + } + pagesOut <- Pages.widget $ PagesIn + { _pagesIn_payments = _init_payments . _paymentIn_init $ paymentIn + } return $ PaymentOut {} diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index f9a2b4e..cf3e115 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Pages ( widget @@ -8,35 +7,45 @@ module View.Payment.Pages , PagesOut(..) ) where -import qualified Data.Text as T -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.Text as T +import Reflex.Dom (Event, Dynamic, MonadWidget) +import qualified Reflex.Dom as R -import Common.Model (Payment(..)) +import Common.Model (Payment (..)) +import Component (ButtonIn (..), ButtonOut (..)) +import qualified Component as Component import qualified Icon data PagesIn = PagesIn { _pagesIn_payments :: [Payment] } -data PagesOut = PagesOut - { +data PagesOut t = PagesOut + { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m PagesOut +widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) widget _ = do - R.divClass "pages" $ do - page Icon.doubleLeftBar - page Icon.doubleLeft - page (R.text . T.pack . show $ (1 :: Integer)) - page (R.text . T.pack . show $ (2 :: Integer)) - page (R.text . T.pack . show $ (3 :: Integer)) - page (R.text . T.pack . show $ (4 :: Integer)) - page (R.text . T.pack . show $ (5 :: Integer)) - page Icon.doubleRight - page Icon.doubleRightBar - return $ PagesOut {} - -page :: forall t m. MonadWidget t m => m () -> m () -page content = R.elClass "button" "page" $ content + currentPage <- R.divClass "pages" $ do + a <- page 1 Icon.doubleLeftBar + b <- page 1 Icon.doubleLeft + c <- page 1 (R.text . T.pack . show $ (1 :: Integer)) + d <- page 2 (R.text . T.pack . show $ (2 :: Integer)) + e <- page 3 (R.text . T.pack . show $ (3 :: Integer)) + f <- page 4 (R.text . T.pack . show $ (4 :: Integer)) + g <- page 5 (R.text . T.pack . show $ (5 :: Integer)) + h <- page 5 Icon.doubleRight + i <- page 5 Icon.doubleRightBar + R.holdDyn 1 $ R.leftmost [ a, b, c, d, e, f, g, h, i ] + return $ PagesOut + { _pagesOut_currentPage = currentPage + } + +page :: forall t m. MonadWidget t m => Int -> m () -> m (Event t Int) +page n content = + ((fmap (const n)) . _buttonOut_clic) <$> (Component.button $ ButtonIn + { _buttonIn_class = "page" + , _buttonIn_content = content + , _buttonIn_waiting = R.never + }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index f3eb9a7..734511d 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.Payment.Table ( widget @@ -8,34 +7,40 @@ module View.Payment.Table , TableOut(..) ) where -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R +import qualified Data.List as L +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Prelude hiding (init) +import Reflex.Dom (MonadWidget, Dynamic) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model as CM -import qualified Common.Util.Text as T +import Common.Model (Category (..), Init (..), Payment (..), + PaymentCategory (..), User (..)) +import qualified Common.Model as CM +import qualified Common.Util.Text as T import qualified Common.View.Format as Format import qualified Icon -data TableIn = TableIn +data TableIn t = TableIn { _tableIn_init :: Init + , _tableIn_currentPage :: Dynamic t Int } data TableOut = TableOut { } -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut +visiblePayments :: Int +visiblePayments = 8 + +widget :: forall t m. MonadWidget t m => TableIn t -> m TableOut widget tableIn = do - R.divClass "table" $ + R.dynText (fmap (T.pack . show) . _tableIn_currentPage $ tableIn) + _ <- R.divClass "table" $ R.divClass "lines" $ do R.divClass "header" $ do R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name @@ -48,39 +53,50 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) + paymentRange = fmap + (\p -> take visiblePayments . drop ((p - 1) * visiblePayments) . reverse . L.sortOn _payment_date $ payments) + (_tableIn_currentPage tableIn) + R.simpleList paymentRange (paymentRow init) return $ TableOut {} -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () +paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () paymentRow init payment = R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment + R.divClass "cell name" . R.dynText . fmap _payment_name $ payment + R.divClass "cell cost" . R.dynText . fmap (Format.price (_init_currency init) . _payment_cost) $ payment + + let user = flip fmap payment $ \p -> CM.findUser (_payment_user p) (_init_users init) R.divClass "cell user" $ - case CM.findUser (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank + R.dynText $ flip fmap user $ \mbUser -> case mbUser of + Just u -> _user_name u + _ -> "" + + let category = flip fmap payment $ \p -> findCategory + (_init_categories init) + (_init_paymentCategories init) + (_payment_name p) + R.divClass "cell category" $ do + let attrs = flip fmap category $ \maybeCategory -> case maybeCategory of + Just c -> M.fromList + [ ("class", "tag") + , ("style", T.concat [ "background-color: ", _category_color c ]) + ] + Nothing -> M.singleton "display" "none" + R.elDynAttr "span" attrs $ + R.dynText $ flip fmap category $ \mbCategory -> case mbCategory of + Just c -> _category_name c + _ -> "" + R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) + R.elClass "span" "shortDate" . R.dynText . fmap (Format.shortDay . _payment_date) $ payment + R.elClass "span" "longDate" . R.dynText . fmap (Format.longDay . _payment_date) $ payment R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank + let modifyAttrs = flip fmap payment $ \p -> + M.fromList [("class", "cell button"), ("display", if _payment_user p == _init_currentUser init then "block" else "none")] + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.edit + R.elDynAttr "div" modifyAttrs $ + R.el "button" $ Icon.delete findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category findCategory categories paymentCategories paymentName = do diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index e164ee7..70c6b1f 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -1,27 +1,25 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} module View.SignIn ( view ) where -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R +import qualified Data.Either as Either +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Time (NominalDiffTime) +import Prelude hiding (error) +import Reflex.Dom (Event, MonadWidget) +import qualified Reflex.Dom as R -import qualified Common.Message as Message +import qualified Common.Message as Message import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) +import Common.Model (SignIn (SignIn)) -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component +import Component (ButtonIn (..), ButtonOut (..), + InputIn (..), InputOut (..)) +import qualified Component as Component view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () view result = @@ -75,11 +73,11 @@ showSignInResult result signInResult = do _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult R.blank - where showInitResult (Left error) = showError error + where showInitResult (Left error) = showError error showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank + showInitResult (Right Nothing) = R.blank - showResult (Left error) = showError error + showResult (Left error) = showError error showResult (Right success) = showSuccess success showError = R.divClass "error" . R.text |