From 47c2a4d6b68c54eed5f7b45671b1ccaf8c0db200 Mon Sep 17 00:00:00 2001 From: Joris Date: Mon, 20 Jan 2020 19:47:23 +0100 Subject: Show payment stats --- client/client.cabal | 2 + client/src/Model/Route.hs | 1 + client/src/View/App.hs | 43 +++++++------ client/src/View/Header.hs | 5 ++ client/src/View/Statistics/Chart.hs | 102 +++++++++++++++++++++++++++++++ client/src/View/Statistics/Statistics.hs | 67 ++++++++++++++++++++ 6 files changed, 203 insertions(+), 17 deletions(-) create mode 100644 client/src/View/Statistics/Chart.hs create mode 100644 client/src/View/Statistics/Statistics.hs (limited to 'client') diff --git a/client/client.cabal b/client/client.cabal index 227aed2..cf2c5a1 100644 --- a/client/client.cabal +++ b/client/client.cabal @@ -86,3 +86,5 @@ Executable client View.Payment.Reducer View.Payment.Table View.SignIn + View.Statistics.Chart + View.Statistics.Statistics diff --git a/client/src/Model/Route.hs b/client/src/Model/Route.hs index 63e5d10..f92e9be 100644 --- a/client/src/Model/Route.hs +++ b/client/src/Model/Route.hs @@ -6,5 +6,6 @@ data Route = RootRoute | IncomeRoute | CategoryRoute + | StatisticsRoute | NotFoundRoute deriving (Eq, Show) diff --git a/client/src/View/App.hs b/client/src/View/App.hs index b0b89fb..71f0234 100644 --- a/client/src/View/App.hs +++ b/client/src/View/App.hs @@ -2,23 +2,24 @@ module View.App ( widget ) where -import qualified Data.Text as T -import Prelude hiding (error, init) -import Reflex.Dom (Dynamic, Event, MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Currency, Init (..), UserId) -import qualified Common.Msg as Msg - -import Model.Route (Route (..)) -import qualified Util.Reflex as ReflexUtil -import qualified Util.Router as Router -import qualified View.Category.Category as Category -import qualified View.Header as Header -import qualified View.Income.Income as Income -import qualified View.NotFound as NotFound -import qualified View.Payment.Payment as Payment -import qualified View.SignIn as SignIn +import qualified Data.Text as T +import Prelude hiding (error, init) +import Reflex.Dom (Dynamic, Event, MonadWidget) +import qualified Reflex.Dom as R + +import Common.Model (Currency, Init (..), UserId) +import qualified Common.Msg as Msg + +import Model.Route (Route (..)) +import qualified Util.Reflex as ReflexUtil +import qualified Util.Router as Router +import qualified View.Category.Category as Category +import qualified View.Header as Header +import qualified View.Income.Income as Income +import qualified View.NotFound as NotFound +import qualified View.Payment.Payment as Payment +import qualified View.SignIn as SignIn +import qualified View.Statistics.Statistics as Statistics widget :: Maybe Init -> IO () widget init = @@ -77,6 +78,11 @@ signedWidget init route = do , Category._in_users = _init_users init } + StatisticsRoute -> + Statistics.view $ Statistics.In + { Statistics._in_currency = _init_currency init + } + NotFoundRoute -> NotFound.view @@ -95,5 +101,8 @@ getRoute = do ["category"] -> CategoryRoute + ["statistics"] -> + StatisticsRoute + _ -> NotFoundRoute diff --git a/client/src/View/Header.hs b/client/src/View/Header.hs index f91c408..ff9f40a 100644 --- a/client/src/View/Header.hs +++ b/client/src/View/Header.hs @@ -67,6 +67,11 @@ links route = do (R.ffor route (attrs CategoryRoute)) (Msg.get Msg.Category_Title) + Link.view + "/statistics" + (R.ffor route (attrs StatisticsRoute)) + (Msg.get Msg.Statistics_Title) + where attrs linkRoute currentRoute = M.singleton "class" $ diff --git a/client/src/View/Statistics/Chart.hs b/client/src/View/Statistics/Chart.hs new file mode 100644 index 0000000..63df2a1 --- /dev/null +++ b/client/src/View/Statistics/Chart.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} + +module View.Statistics.Chart + ( view + , In(..) + , Dataset(..) + ) where + +import qualified Control.Concurrent as Concurrent +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson ((.=)) +import qualified Data.Aeson as AE +import qualified Data.Map as M +import Data.Text (Text) +import Language.Javascript.JSaddle (JSString, JSVal) +import qualified Language.Javascript.JSaddle.Value as JSValue +import Reflex.Dom (MonadWidget) +import qualified Reflex.Dom as R +-- import GHCJS.Foreign.Callback + + +#ifdef __GHCJS__ +foreign import javascript unsafe "new Chart(document.getElementById($1), $2);" drawChart :: JSString -> JSVal -> IO () +#else +drawChart = error "drawChart: only available from JavaScript" +#endif + +data In = In + { _in_title :: Text + , _in_labels :: [Text] + , _in_datasets :: [Dataset] + } + +data Dataset = Dataset + { _dataset_label :: Text + , _dataset_data :: [Int] + , _dataset_color :: Text + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + R.divClass "g-Chart" $ + R.elAttr "canvas" (M.singleton "id" "chart") $ + R.blank + + liftIO $ Concurrent.forkIO $ do + Concurrent.threadDelay 500000 + config <- JSValue.valMakeJSON (configToJson input) + drawChart "chart" config + + return () + +configToJson (In title labels datasets) = + AE.object + [ "type" .= AE.String "line" + , "data" .= + AE.object + [ "labels" .= labels + , "datasets" .= map datasetToJson datasets + ] + , "options" .= + AE.object + [ "responsive" .= True + , "title" .= + AE.object + [ "display" .= True + , "text" .= title + ] + , "tooltips" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= False + ] + , "hover" .= + AE.object + [ "mode" .= AE.String "nearest" + , "intersect" .= True + ] + , "scales" .= + AE.object + [ "yAxes" .= + [ [ AE.object + [ "ticks" .= + AE.object + [ "beginAtZero" .= True ] + ] + ] + ] + ] + ] + ] + +datasetToJson (Dataset label data_ color) = + AE.object + [ "label" .= label + , "data" .= data_ + , "fill" .= False + , "backgroundColor" .= color + , "borderColor" .= color + ] diff --git a/client/src/View/Statistics/Statistics.hs b/client/src/View/Statistics/Statistics.hs new file mode 100644 index 0000000..71f93d4 --- /dev/null +++ b/client/src/View/Statistics/Statistics.hs @@ -0,0 +1,67 @@ +module View.Statistics.Statistics + ( view + , In(..) + ) where + +import Control.Monad (void) +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time.Calendar (Day) +import qualified Data.Time.Calendar as Calendar +import Loadable (Loadable) +import qualified Loadable +import Reflex.Dom (Dynamic, MonadWidget) +import qualified Reflex.Dom as R +import qualified Util.Ajax as AjaxUtil +import qualified View.Statistics.Chart as Chart + +import Common.Model (Category (..), Currency, PaymentStats) +import qualified Common.Msg as Msg +import qualified Common.View.Format as Format + +data In = In + { _in_currency :: Currency + } + +view :: forall t m. MonadWidget t m => In -> m () +view input = do + + categories <- AjaxUtil.getNow "api/allCategories" + statistics <- AjaxUtil.getNow "api/statistics" + let categoriesAndStatistics = (\c s -> (,) <$> c <*> s) <$> categories <*> statistics + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ Msg.get Msg.Statistics_Title + + void . R.dyn . R.ffor categoriesAndStatistics . Loadable.viewHideValueWhileLoading $ + stats (_in_currency input) + +stats :: forall t m. MonadWidget t m => Currency -> ([Category], PaymentStats) -> m () +stats currency (categories, stats) = + Chart.view $ Chart.In + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averageEachMonth) + , Chart._in_labels = map (Format.monthAndYear . fst) stats + , Chart._in_datasets = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_Total + , Chart._dataset_data = totalSeries + , Chart._dataset_color = "#555555" + } : (map categoryDataset categories) + } + + where + averageEachMonth = + Format.price currency $ sum totalSeries `div` length stats + + totalSeries = + map (sum . map snd . M.toList . snd) stats + + categoryDataset category = + Chart.Dataset + { Chart._dataset_label = _category_name category + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . snd) stats + , Chart._dataset_color = _category_color category + } -- cgit v1.2.3