diff options
Diffstat (limited to 'client/src/View/Statistics')
| -rw-r--r-- | client/src/View/Statistics/Chart.hs | 102 | ||||
| -rw-r--r-- | client/src/View/Statistics/Statistics.hs | 85 |
2 files changed, 187 insertions, 0 deletions
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..d931b2b --- /dev/null +++ b/client/src/View/Statistics/Statistics.hs @@ -0,0 +1,85 @@ +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, Income, + MonthStats (..), Stats, User (..)) +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 + + users <- AjaxUtil.getNow "api/users" + categories <- AjaxUtil.getNow "api/allCategories" + statistics <- AjaxUtil.getNow "api/statistics" + + let loadable = (\u c s -> (,,) <$> u <*> c <*> s) <$> users <*> categories <*> statistics + + R.divClass "withMargin" $ + R.divClass "titleButton" $ + R.el "h1" $ + R.text $ Msg.get Msg.Statistics_Title + + void . R.dyn . R.ffor loadable . Loadable.viewHideValueWhileLoading $ + stats (_in_currency input) + +stats :: forall t m. MonadWidget t m => Currency -> ([User], [Category], Stats) -> m () +stats currency (users, categories, stats) = + Chart.view $ Chart.In + { Chart._in_title = Msg.get (Msg.Statistics_ByMonthsAndMean averagePayment averageIncome) + , Chart._in_labels = map (Format.monthAndYear . _monthStats_start) stats + , Chart._in_datasets = totalIncomeDataset : totalPaymentDataset : (map categoryDataset categories) + } + + where + averageIncome = + Format.price currency $ sum totalIncomes `div` length stats + + totalIncomeDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalIncomes + , Chart._dataset_data = totalIncomes + , Chart._dataset_color = "#222222" + } + + totalIncomes = + map (sum . map snd . M.toList . _monthStats_incomeByUser) stats + + averagePayment = + Format.price currency $ sum totalPayments `div` length stats + + totalPaymentDataset = + Chart.Dataset + { Chart._dataset_label = Msg.get Msg.Statistics_TotalPayments + , Chart._dataset_data = totalPayments + , Chart._dataset_color = "#555555" + } + + totalPayments = + map (sum . map snd . M.toList . _monthStats_paymentsByCategory) stats + + categoryDataset category = + Chart.Dataset + { Chart._dataset_label = _category_name category + , Chart._dataset_data = map (M.findWithDefault 0 (_category_id category) . _monthStats_paymentsByCategory) stats + , Chart._dataset_color = _category_color category + } |