aboutsummaryrefslogtreecommitdiff
path: root/client/src
diff options
context:
space:
mode:
Diffstat (limited to 'client/src')
-rw-r--r--client/src/Component.hs4
-rw-r--r--client/src/Component/Button.hs17
-rw-r--r--client/src/Component/Input.hs9
-rw-r--r--client/src/Icon.hs11
-rw-r--r--client/src/Main.hs28
-rw-r--r--client/src/View/App.hs23
-rw-r--r--client/src/View/Header.hs27
-rw-r--r--client/src/View/Payment.hs29
-rw-r--r--client/src/View/Payment/Pages.hs57
-rw-r--r--client/src/View/Payment/Table.hs102
-rw-r--r--client/src/View/SignIn.hs36
11 files changed, 183 insertions, 160 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 22:31:26 +0000