Merge branch 'with-ghcjs' into 'master'

Use Haskell on the frontend

See merge request guyonvarch/shared-cost!2

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
+        }