From 898e7ed11ab0958fcdaf65b99b33f7b04787630a Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 24 Sep 2017 22:14:48 +0200
Subject: Bootstrap with GHCJS and reflex:

- setup login and logout,
- first draft of payment view.
---
 src/client/View/App.hs           |  44 ++++++++++++
 src/client/View/Color.elm        |  12 ----
 src/client/View/Date.elm         |  57 ---------------
 src/client/View/Errors.elm       |  21 ------
 src/client/View/Events.elm       |  15 ----
 src/client/View/Form.elm         | 152 ---------------------------------------
 src/client/View/Header.elm       |  60 ----------------
 src/client/View/Header.hs        |  86 ++++++++++++++++++++++
 src/client/View/Payment.hs       |  33 +++++++++
 src/client/View/Payment/Table.hs |  90 +++++++++++++++++++++++
 src/client/View/Plural.elm       |  11 ---
 src/client/View/SignIn.hs        |  86 ++++++++++++++++++++++
 12 files changed, 339 insertions(+), 328 deletions(-)
 create mode 100644 src/client/View/App.hs
 delete mode 100644 src/client/View/Color.elm
 delete mode 100644 src/client/View/Date.elm
 delete mode 100644 src/client/View/Errors.elm
 delete mode 100644 src/client/View/Events.elm
 delete mode 100644 src/client/View/Form.elm
 delete mode 100644 src/client/View/Header.elm
 create mode 100644 src/client/View/Header.hs
 create mode 100644 src/client/View/Payment.hs
 create mode 100644 src/client/View/Payment/Table.hs
 delete mode 100644 src/client/View/Plural.elm
 create mode 100644 src/client/View/SignIn.hs

(limited to 'src/client/View')

diff --git a/src/client/View/App.hs b/src/client/View/App.hs
new file mode 100644
index 0000000..1466811
--- /dev/null
+++ b/src/client/View/App.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.App
+  ( widget
+  ) where
+
+import qualified Reflex.Dom as R
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(..))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+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
+
+widget :: InitResult -> IO ()
+widget initResult =
+  R.mainWidget $ do
+    headerOut <- Header.view $ HeaderIn
+      { _headerIn_initResult = initResult
+      }
+
+    let signOut = Header._headerOut_signOut headerOut
+
+        initialContent = case initResult of
+          InitSuccess initSuccess -> do
+            _ <- Payment.widget $ PaymentIn
+              { _paymentIn_init = initSuccess
+              }
+            return ()
+          InitEmpty result ->
+            SignIn.view result
+
+        signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
+
+    _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
+
+    R.blank
diff --git a/src/client/View/Color.elm b/src/client/View/Color.elm
deleted file mode 100644
index a2a20c7..0000000
--- a/src/client/View/Color.elm
+++ /dev/null
@@ -1,12 +0,0 @@
-module View.Color exposing (..)
-
-import Color exposing (Color)
-
-chestnutRose : Color
-chestnutRose = Color.rgb 207 92 86
-
-white : Color
-white = Color.white
-
-silver : Color
-silver = Color.rgb 200 200 200
diff --git a/src/client/View/Date.elm b/src/client/View/Date.elm
deleted file mode 100644
index 6df971b..0000000
--- a/src/client/View/Date.elm
+++ /dev/null
@@ -1,57 +0,0 @@
-module View.Date exposing
-  ( shortMonthAndYear
-  , shortView
-  , longView
-  , monthView
-  )
-
-import Date exposing (..)
-import Date.Extra.Core as Date
-import String
-
-import Model.Translations exposing (..)
-
-shortMonthAndYear : Month -> Int -> Translations -> String
-shortMonthAndYear month year translations =
-  let params =
-        [ String.pad 2 '0' (toString (Date.monthToInt month))
-        , toString year
-        ]
-  in  getParamMessage params translations "ShortMonthAndYear"
-
-shortView : Date -> Translations -> String
-shortView date translations =
-  let params =
-        [ String.pad 2 '0' (toString (Date.day date))
-        , String.pad 2 '0' (toString (Date.monthToInt (Date.month date)))
-        , toString (Date.year date)
-        ]
-  in  getParamMessage params translations "ShortDate"
-
-longView : Date -> Translations -> String
-longView date translations =
-  let params =
-        [ toString (Date.day date)
-        , (getMessage translations (getMonthKey (Date.month date)))
-        , toString (Date.year date)
-        ]
-  in  getParamMessage params translations "LongDate"
-
-monthView : Translations -> Month -> String
-monthView translations month = getMessage translations (getMonthKey month)
-
-getMonthKey : Month -> String
-getMonthKey month =
-  case month of
-    Jan -> "January"
-    Feb -> "February"
-    Mar -> "March"
-    Apr -> "April"
-    May -> "May"
-    Jun -> "June"
-    Jul -> "July"
-    Aug -> "August"
-    Sep -> "September"
-    Oct -> "October"
-    Nov -> "November"
-    Dec -> "December"
diff --git a/src/client/View/Errors.elm b/src/client/View/Errors.elm
deleted file mode 100644
index 3e25c99..0000000
--- a/src/client/View/Errors.elm
+++ /dev/null
@@ -1,21 +0,0 @@
-module View.Errors exposing
-  ( view
-  )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import Model.Translations exposing (Translations, getMessage)
-
-view : Translations -> List String -> Html msg
-view translations errors =
-  ul
-    [ class "errors" ]
-    ( List.map (errorView translations) errors)
-
-errorView : Translations -> String -> Html msg
-errorView translations error =
-  li
-    [ class "error" ]
-    [ text <| getMessage translations error ]
diff --git a/src/client/View/Events.elm b/src/client/View/Events.elm
deleted file mode 100644
index d71d67d..0000000
--- a/src/client/View/Events.elm
+++ /dev/null
@@ -1,15 +0,0 @@
-module View.Events exposing
-  ( onSubmitPrevDefault
-  )
-
-import Json.Decode as Decode
-import Html exposing (..)
-import Html.Events exposing (..)
-import Html.Attributes exposing (..)
-
-onSubmitPrevDefault : msg -> Attribute msg
-onSubmitPrevDefault value =
-  onWithOptions
-    "submit"
-    { defaultOptions | preventDefault = True }
-    (Decode.succeed value)
diff --git a/src/client/View/Form.elm b/src/client/View/Form.elm
deleted file mode 100644
index 977ca0a..0000000
--- a/src/client/View/Form.elm
+++ /dev/null
@@ -1,152 +0,0 @@
-module View.Form exposing
-  ( textInput
-  , colorInput
-  , selectInput
-  , radioInputs
-  , hiddenSubmit
-  )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-import Maybe.Extra as Maybe
-
-import FontAwesome
-import View.Color as Color
-
-import Form exposing (Form, FieldState)
-import Form.Input as Input
-import Form.Error as FormError exposing (ErrorValue(..))
-import Form.Field as Field
-
-import Msg exposing (Msg)
-
-import LoggedData exposing (LoggedData)
-
-import Model.Translations as Translations exposing (Translations)
-
-textInput : Translations -> Form String a -> String -> String -> Html Form.Msg
-textInput translations form formName fieldName =
-  let field = Form.getFieldAsString fieldName form
-      fieldId = formName ++ fieldName
-  in  div
-        [ classList
-            [ ("textInput", True)
-            , ("error", Maybe.isJust field.liveError)
-            ]
-        ]
-        [ Input.textInput
-            field
-            [ id fieldId
-            , classList [ ("filled", Maybe.isJust field.value) ]
-            , value (Maybe.withDefault "" field.value)
-            ]
-        , label
-            [ for fieldId ]
-            [ text (Translations.getMessage translations fieldId) ]
-        , button
-            [ type_ "button"
-            , onClick (Form.Input fieldName Form.Text Field.EmptyField)
-            , tabindex -1
-            ]
-            [ FontAwesome.times Color.silver 15 ]
-        , formError translations field
-        ]
-
-colorInput : Translations -> Form String a -> String -> String -> Html Form.Msg
-colorInput translations form formName fieldName =
-  let field = Form.getFieldAsString fieldName form
-  in  div
-        [ classList
-            [ ("colorInput", True)
-            , ("error", Maybe.isJust field.liveError)
-            ]
-        ]
-        [ label
-            [ for (formName ++ fieldName) ]
-            [ text (Translations.getMessage translations (formName ++ fieldName)) ]
-        , Input.textInput
-            field
-            [ id (formName ++ fieldName)
-            , type_ "color"
-            ]
-        ]
-
-radioInputs : Translations -> Form String a -> String -> String -> List String -> Html Form.Msg
-radioInputs translations form formName radioName fieldNames =
-  let field = Form.getFieldAsString radioName form
-  in  div
-        [ classList
-            [ ("radioGroup", True)
-            , ("error", Maybe.isJust field.liveError)
-            ]
-        ]
-        [ div
-            [ class "title" ]
-            [ text (Translations.getMessage translations (formName ++ radioName) ) ]
-        , div
-            [ class "radioInputs" ]
-            (List.map (radioInput translations field formName) fieldNames)
-        , formError translations field
-        ]
-
-radioInput : Translations -> FieldState String String -> String -> String -> Html Form.Msg
-radioInput translations field formName fieldName =
-  div
-    [ class "radioInput" ]
-    [ Input.radioInput
-        field.path
-        field
-        [ id (formName ++ fieldName)
-        , value fieldName
-        , checked (field.value == Just fieldName)
-        ]
-    , label
-        [ for (formName ++ fieldName) ]
-        [ text (Translations.getMessage translations (formName ++ fieldName))
-        ]
-    ]
-
-selectInput : Translations -> Form String a -> String -> String -> List (String, String) -> Html Form.Msg
-selectInput translations form formName selectName options =
-  let field = Form.getFieldAsString selectName form
-      fieldId = formName ++ selectName
-  in  div
-        [ classList
-            [ ("selectInput", True)
-            , ("error", Maybe.isJust field.liveError)
-            ]
-        ]
-        [ label
-            [ for fieldId ]
-            [ text (Translations.getMessage translations fieldId) ]
-        , Input.selectInput
-            (("", "") :: options)
-            field
-            [ id fieldId ]
-        , formError translations field
-        ]
-
-formError : Translations -> FieldState String a -> Html msg
-formError translations field =
-  case field.liveError of
-    Just error ->
-      let errorElement error params =
-            div
-              [ class "errorMessage" ]
-              [ text (Translations.getParamMessage params translations error) ]
-      in  case error of
-            CustomError key -> errorElement key []
-            SmallerIntThan n -> errorElement "SmallerIntThan" [toString n]
-            GreaterIntThan n -> errorElement "GreaterIntThan" [toString n]
-            error -> errorElement (toString error) []
-    Nothing ->
-      text ""
-
-hiddenSubmit : msg -> Html msg
-hiddenSubmit msg =
-  button
-    [ style [ ("display", "none") ]
-    , onClick msg
-    ]
-    []
diff --git a/src/client/View/Header.elm b/src/client/View/Header.elm
deleted file mode 100644
index 12fb87c..0000000
--- a/src/client/View/Header.elm
+++ /dev/null
@@ -1,60 +0,0 @@
-module View.Header exposing
-  ( view
-  )
-
-import Dict
-
-import FontAwesome
-import View.Color as Color
-
-import Page exposing (..)
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import Model exposing (Model)
-import Model.Translations exposing (getMessage)
-import Msg exposing (..)
-import Model.View exposing (..)
-
-view : Model -> Html Msg
-view model =
-  header
-    []
-    (  [ div [ class "title" ] [ text (getMessage model.translations "SharedCost") ] ]
-    ++ let item page name =
-             a
-               [ href (Page.toHash page)
-               , classList
-                   [ ("item", True)
-                   , ("current", model.page == page)
-                   ]
-               ]
-               [ text (getMessage model.translations name)
-               ]
-       in  case model.view of
-             LoggedInView { me, users } ->
-               [ item Home "PaymentsTitle"
-               , item Income "Income"
-               , item Categories "Categories"
-               , item Statistics "Statistics"
-               , div
-                   [ class "nameSignOut" ]
-                   [ div
-                       [ class "name" ]
-                       [ Dict.get me users
-                           |> Maybe.map .name
-                           |> Maybe.withDefault ""
-                           |> text
-                       ]
-                   , button
-                       [ class "signOut item"
-                       , onClick SignOut
-                       ]
-                       [ FontAwesome.power_off Color.white 30 ]
-                   ]
-               ]
-             _ ->
-               []
-    )
diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs
new file mode 100644
index 0000000..32738f1
--- /dev/null
+++ b/src/client/View/Header.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Header
+  ( view
+  , HeaderIn(..)
+  , 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 Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (InitResult(..), Init(..), User(..))
+import qualified Common.Model.User as User
+
+import Component.Button (ButtonIn(..))
+import qualified Component.Button as Component
+import qualified Icon
+
+data HeaderIn = HeaderIn
+  { _headerIn_initResult :: InitResult
+  }
+
+data HeaderOut t = HeaderOut
+  { _headerOut_signOut :: Event t ()
+  }
+
+view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
+view headerIn =
+  R.el "header" $ do
+
+    R.divClass "title" $
+      R.text $ Message.get Key.App_Title
+
+    signOut <- nameSignOut $ _headerIn_initResult headerIn
+
+    return $ HeaderOut
+      { _headerOut_signOut = signOut
+      }
+
+nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
+nameSignOut initResult = case initResult of
+  (InitSuccess init) -> do
+    rec
+      attr <- R.holdDyn
+        (M.singleton "class" "nameSignOut")
+        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
+
+      signOut <- R.elDynAttr "nameSignOut" attr $ do
+        case User.find (_init_currentUser init) (_init_users init) of
+          Just user -> R.divClass "name" $ R.text (_user_name user)
+          Nothing -> R.blank
+        signOutButton
+
+    return signOut
+  _ ->
+    return R.never
+
+signOutButton :: forall t m. MonadWidget t m => m (Event t ())
+signOutButton = do
+  rec
+    signOut <- Component.button $ ButtonIn
+      { Component._buttonIn_class = "signOut item"
+      , Component._buttonIn_content = Icon.signOut
+      , Component._buttonIn_waiting = waiting
+      }
+    let signOutClic = Component._buttonOut_clic signOut
+        waiting = R.leftmost
+          [ fmap (const True) signOutClic
+          , fmap (const False) signOutSuccess
+          ]
+    signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime)
+
+  return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess
+
+  where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
+        askSignOut signOut =
+          fmap getResult <$> R.performRequestAsync xhrRequest
+          where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
+                getResult = (== 200) . R._xhrResponse_status
diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs
new file mode 100644
index 0000000..e80790b
--- /dev/null
+++ b/src/client/View/Payment.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment
+  ( widget
+  , PaymentIn(..)
+  , PaymentOut(..)
+  ) where
+
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+import Common.Model (Init)
+
+import View.Payment.Table (TableIn(..))
+import qualified View.Payment.Table as Table
+
+data PaymentIn = PaymentIn
+  { _paymentIn_init :: Init
+  }
+
+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
+      }
+    return $ PaymentOut {}
diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs
new file mode 100644
index 0000000..878e7da
--- /dev/null
+++ b/src/client/View/Payment/Table.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RecursiveDo               #-}
+
+module View.Payment.Table
+  ( widget
+  , TableIn(..)
+  , 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 Common.Message as Message
+import qualified Common.Message.Key as Key
+import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..))
+import qualified Common.Model.User as User
+import qualified Common.Util.Text as T
+import qualified Common.View.Format as Format
+
+import qualified Icon
+
+data TableIn = TableIn
+  { _tableIn_init :: Init
+  }
+
+data TableOut = TableOut
+  {
+  }
+
+widget :: forall t m. MonadWidget t m => TableIn -> m TableOut
+widget tableIn = do
+  R.divClass "table" $
+    R.divClass "lines" $ do
+      R.divClass "header" $ do
+        R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
+        R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
+        R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
+        R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
+        R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
+        R.divClass "cell" $ R.blank
+        R.divClass "cell" $ R.blank
+        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)
+  return $ TableOut {}
+
+paymentRow :: forall t m. MonadWidget t m => Init -> 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 user" $
+      case User.find (_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.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.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
+
+findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
+findCategory categories paymentCategories paymentName = do
+  paymentCategory <- L.find
+    ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
+    paymentCategories
+  L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
diff --git a/src/client/View/Plural.elm b/src/client/View/Plural.elm
deleted file mode 100644
index c36eaca..0000000
--- a/src/client/View/Plural.elm
+++ /dev/null
@@ -1,11 +0,0 @@
-module View.Plural exposing
-  ( plural
-  )
-
-import Model.Translations exposing (Translations, getMessage)
-
-plural : Translations -> Int -> String -> String -> String
-plural translations n single multiple =
-  let singleMessage = getMessage translations single
-      multipleMessage = getMessage translations multiple
-  in  (toString n) ++ " " ++ if n <= 1 then singleMessage else multipleMessage
diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs
new file mode 100644
index 0000000..e164ee7
--- /dev/null
+++ b/src/client/View/SignIn.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# 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 Common.Message as Message
+import qualified Common.Message.Key as Key
+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
+
+view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
+view result =
+  R.divClass "signIn" $ do
+    rec
+      input <- Component.input $ InputIn
+        { _inputIn_reset = R.ffilter Either.isRight signInResult
+        , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder
+        }
+
+      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
+
+      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
+        [ fmap (const True) userWantsEmailValidation
+        , fmap (const False) signInResult
+        ]
+
+      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
+
+      let validatedEmail = R.tagPromptlyDyn
+            (_inputOut_value input)
+            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
+
+      let waiting = R.leftmost
+            [ fmap (const True) validatedEmail
+            , fmap (const False) signInResult
+            ]
+
+      button <- Component.button $ ButtonIn
+        { _buttonIn_class = ""
+        , _buttonIn_content = R.text (Message.get Key.SignIn_Button)
+        , _buttonIn_waiting = waiting
+        }
+
+      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
+
+    showSignInResult result signInResult
+
+askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
+askSignIn email =
+  fmap getResult <$> R.performRequestAsync xhrRequest
+  where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email
+        getResult response =
+          case R._xhrResponse_responseText response of
+            Just key ->
+              if R._xhrResponse_status response == 200 then Right key else Left key
+            _ -> Left "NoKey"
+
+showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
+showSignInResult result signInResult = do
+  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
+  R.blank
+
+  where showInitResult (Left error) = showError error
+        showInitResult (Right (Just success)) = showSuccess success
+        showInitResult (Right Nothing) = R.blank
+
+        showResult (Left error) = showError error
+        showResult (Right success) = showSuccess success
+
+        showError = R.divClass "error" . R.text
+        showSuccess = R.divClass "success" . R.text
-- 
cgit v1.2.3


From 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 Mon Sep 17 00:00:00 2001
From: Joris
Date: Wed, 8 Nov 2017 23:47:26 +0100
Subject: Use a better project structure

---
 src/client/View/App.hs           | 44 --------------------
 src/client/View/Header.hs        | 86 --------------------------------------
 src/client/View/Payment.hs       | 33 ---------------
 src/client/View/Payment/Table.hs | 90 ----------------------------------------
 src/client/View/SignIn.hs        | 86 --------------------------------------
 5 files changed, 339 deletions(-)
 delete mode 100644 src/client/View/App.hs
 delete mode 100644 src/client/View/Header.hs
 delete mode 100644 src/client/View/Payment.hs
 delete mode 100644 src/client/View/Payment/Table.hs
 delete mode 100644 src/client/View/SignIn.hs

(limited to 'src/client/View')

diff --git a/src/client/View/App.hs b/src/client/View/App.hs
deleted file mode 100644
index 1466811..0000000
--- a/src/client/View/App.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
-
-module View.App
-  ( widget
-  ) where
-
-import qualified Reflex.Dom as R
-import Prelude hiding (init, error)
-
-import Common.Model (InitResult(..))
-import qualified Common.Message as Message
-import qualified Common.Message.Key as Key
-
-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
-
-widget :: InitResult -> IO ()
-widget initResult =
-  R.mainWidget $ do
-    headerOut <- Header.view $ HeaderIn
-      { _headerIn_initResult = initResult
-      }
-
-    let signOut = Header._headerOut_signOut headerOut
-
-        initialContent = case initResult of
-          InitSuccess initSuccess -> do
-            _ <- Payment.widget $ PaymentIn
-              { _paymentIn_init = initSuccess
-              }
-            return ()
-          InitEmpty result ->
-            SignIn.view result
-
-        signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess)
-
-    _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut)
-
-    R.blank
diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs
deleted file mode 100644
index 32738f1..0000000
--- a/src/client/View/Header.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
-
-module View.Header
-  ( view
-  , HeaderIn(..)
-  , 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 Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (InitResult(..), Init(..), User(..))
-import qualified Common.Model.User as User
-
-import Component.Button (ButtonIn(..))
-import qualified Component.Button as Component
-import qualified Icon
-
-data HeaderIn = HeaderIn
-  { _headerIn_initResult :: InitResult
-  }
-
-data HeaderOut t = HeaderOut
-  { _headerOut_signOut :: Event t ()
-  }
-
-view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t)
-view headerIn =
-  R.el "header" $ do
-
-    R.divClass "title" $
-      R.text $ Message.get Key.App_Title
-
-    signOut <- nameSignOut $ _headerIn_initResult headerIn
-
-    return $ HeaderOut
-      { _headerOut_signOut = signOut
-      }
-
-nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ())
-nameSignOut initResult = case initResult of
-  (InitSuccess init) -> do
-    rec
-      attr <- R.holdDyn
-        (M.singleton "class" "nameSignOut")
-        (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut)
-
-      signOut <- R.elDynAttr "nameSignOut" attr $ do
-        case User.find (_init_currentUser init) (_init_users init) of
-          Just user -> R.divClass "name" $ R.text (_user_name user)
-          Nothing -> R.blank
-        signOutButton
-
-    return signOut
-  _ ->
-    return R.never
-
-signOutButton :: forall t m. MonadWidget t m => m (Event t ())
-signOutButton = do
-  rec
-    signOut <- Component.button $ ButtonIn
-      { Component._buttonIn_class = "signOut item"
-      , Component._buttonIn_content = Icon.signOut
-      , Component._buttonIn_waiting = waiting
-      }
-    let signOutClic = Component._buttonOut_clic signOut
-        waiting = R.leftmost
-          [ fmap (const True) signOutClic
-          , fmap (const False) signOutSuccess
-          ]
-    signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime)
-
-  return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess
-
-  where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool)
-        askSignOut signOut =
-          fmap getResult <$> R.performRequestAsync xhrRequest
-          where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut
-                getResult = (== 200) . R._xhrResponse_status
diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs
deleted file mode 100644
index e80790b..0000000
--- a/src/client/View/Payment.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
-
-module View.Payment
-  ( widget
-  , PaymentIn(..)
-  , PaymentOut(..)
-  ) where
-
-import Reflex.Dom (MonadWidget)
-import qualified Reflex.Dom as R
-
-import Common.Model (Init)
-
-import View.Payment.Table (TableIn(..))
-import qualified View.Payment.Table as Table
-
-data PaymentIn = PaymentIn
-  { _paymentIn_init :: Init
-  }
-
-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
-      }
-    return $ PaymentOut {}
diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs
deleted file mode 100644
index 878e7da..0000000
--- a/src/client/View/Payment/Table.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings         #-}
-{-# LANGUAGE RecursiveDo               #-}
-
-module View.Payment.Table
-  ( widget
-  , TableIn(..)
-  , 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 Common.Message as Message
-import qualified Common.Message.Key as Key
-import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..))
-import qualified Common.Model.User as User
-import qualified Common.Util.Text as T
-import qualified Common.View.Format as Format
-
-import qualified Icon
-
-data TableIn = TableIn
-  { _tableIn_init :: Init
-  }
-
-data TableOut = TableOut
-  {
-  }
-
-widget :: forall t m. MonadWidget t m => TableIn -> m TableOut
-widget tableIn = do
-  R.divClass "table" $
-    R.divClass "lines" $ do
-      R.divClass "header" $ do
-        R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name
-        R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost
-        R.divClass "cell user" $ R.text $ Message.get Key.Payment_User
-        R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category
-        R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date
-        R.divClass "cell" $ R.blank
-        R.divClass "cell" $ R.blank
-        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)
-  return $ TableOut {}
-
-paymentRow :: forall t m. MonadWidget t m => Init -> 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 user" $
-      case User.find (_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.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.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
-
-findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category
-findCategory categories paymentCategories paymentName = do
-  paymentCategory <- L.find
-    ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name)
-    paymentCategories
-  L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories
diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs
deleted file mode 100644
index e164ee7..0000000
--- a/src/client/View/SignIn.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# 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 Common.Message as Message
-import qualified Common.Message.Key as Key
-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
-
-view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m ()
-view result =
-  R.divClass "signIn" $ do
-    rec
-      input <- Component.input $ InputIn
-        { _inputIn_reset = R.ffilter Either.isRight signInResult
-        , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder
-        }
-
-      let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button
-
-      dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $
-        [ fmap (const True) userWantsEmailValidation
-        , fmap (const False) signInResult
-        ]
-
-      uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail
-
-      let validatedEmail = R.tagPromptlyDyn
-            (_inputOut_value input)
-            (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail)
-
-      let waiting = R.leftmost
-            [ fmap (const True) validatedEmail
-            , fmap (const False) signInResult
-            ]
-
-      button <- Component.button $ ButtonIn
-        { _buttonIn_class = ""
-        , _buttonIn_content = R.text (Message.get Key.SignIn_Button)
-        , _buttonIn_waiting = waiting
-        }
-
-      signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime)
-
-    showSignInResult result signInResult
-
-askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text))
-askSignIn email =
-  fmap getResult <$> R.performRequestAsync xhrRequest
-  where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email
-        getResult response =
-          case R._xhrResponse_responseText response of
-            Just key ->
-              if R._xhrResponse_status response == 200 then Right key else Left key
-            _ -> Left "NoKey"
-
-showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m ()
-showSignInResult result signInResult = do
-  _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult
-  R.blank
-
-  where showInitResult (Left error) = showError error
-        showInitResult (Right (Just success)) = showSuccess success
-        showInitResult (Right Nothing) = R.blank
-
-        showResult (Left error) = showError error
-        showResult (Right success) = showSuccess success
-
-        showError = R.divClass "error" . R.text
-        showSuccess = R.divClass "success" . R.text
-- 
cgit v1.2.3