diff options
author | Joris | 2017-11-13 23:56:40 +0100 |
---|---|---|
committer | Joris | 2017-11-14 00:03:10 +0100 |
commit | 5a63f7be9375e3ab888e4232dd7ef72c2f1ffae1 (patch) | |
tree | 4884de1d03bc47ba8f06b2cf68365d9eed9e0d39 /client | |
parent | 213cf7ede058b781fc957de2cd9f6a5988c08004 (diff) |
Setup stylish-haskell
Diffstat (limited to 'client')
-rw-r--r-- | client/Setup.hs | 2 | ||||
-rw-r--r-- | client/client.cabal | 73 | ||||
-rw-r--r-- | client/src/Component.hs | 4 | ||||
-rw-r--r-- | client/src/Component/Button.hs | 17 | ||||
-rw-r--r-- | client/src/Component/Input.hs | 9 | ||||
-rw-r--r-- | client/src/Icon.hs | 11 | ||||
-rw-r--r-- | client/src/Main.hs | 28 | ||||
-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 |
13 files changed, 224 insertions, 194 deletions
diff --git a/client/Setup.hs b/client/Setup.hs index 9a994af..4467109 100644 --- a/client/Setup.hs +++ b/client/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/client/client.cabal b/client/client.cabal index 9d3e873..ac74d9c 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -1,34 +1,41 @@ -name: client -version: 0.0.1 -license: GPL-3 -license-file: LICENSE -author: Joris Guyonvarch -maintainer: joris@guyonvarch.me -category: Web -build-type: Simple -cabal-version: >=1.10 +Name: client +Version: 0.0.1 +License: GPL-3 +License-file: LICENSE +Author: Joris Guyonvarch +Maintainer: joris@guyonvarch.me +Category: Web +Build-type: Simple +Cabal-version: >=1.10 -executable client - main-is: Main.hs - ghc-options: -Wall -Werror - build-depends: aeson - , base >=4.9 && <4.11 - , bytestring - , common - , containers - , jsaddle-dom - , reflex-dom - , text - , time - hs-source-dirs: src - default-language: Haskell2010 - other-modules: Component.Button - , Component.Input - , Icon - , Main - , View.App - , View.Header - , View.Payment - , View.Payment.Pages - , View.Payment.Table - , View.SignIn +Executable client + Main-Is: Main.hs + Ghc-options: -Wall -Werror + Hs-source-dirs: src + Default-language: Haskell2010 + Extensions: + ExistentialQuantification + MultiParamTypeClasses + + Build-depends: + aeson + , base >=4.9 && <4.11 + , bytestring + , common + , containers + , jsaddle-dom + , reflex-dom + , text + , time + + other-modules: + Component.Button + Component.Input + Icon + Main + View.App + View.Header + View.Payment + View.Payment.Pages + View.Payment.Table + View.SignIn 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 |