aboutsummaryrefslogtreecommitdiff
path: root/src/client
diff options
context:
space:
mode:
Diffstat (limited to 'src/client')
-rw-r--r--src/client/Chart/Api.elm41
-rw-r--r--src/client/Chart/Model.elm73
-rw-r--r--src/client/Chart/View.elm182
l---------src/client/Common1
-rw-r--r--src/client/Component/Button.hs53
-rw-r--r--src/client/Component/Input.hs34
-rw-r--r--src/client/Debug.hs17
-rw-r--r--src/client/Dialog.elm165
-rw-r--r--src/client/Dialog/AddCategory/Model.elm54
-rw-r--r--src/client/Dialog/AddCategory/View.elm72
-rw-r--r--src/client/Dialog/AddIncome/Model.elm53
-rw-r--r--src/client/Dialog/AddIncome/View.elm72
-rw-r--r--src/client/Dialog/AddPayment/Model.elm70
-rw-r--r--src/client/Dialog/AddPayment/View.elm95
-rw-r--r--src/client/Dialog/Model.elm23
-rw-r--r--src/client/Dialog/Msg.elm15
-rw-r--r--src/client/Dialog/Update.elm74
-rw-r--r--src/client/Icon.hs44
-rw-r--r--src/client/Init.elm30
-rw-r--r--src/client/LoggedData.elm44
-rw-r--r--src/client/LoggedIn/Category/Table.elm123
-rw-r--r--src/client/LoggedIn/Category/View.elm34
-rw-r--r--src/client/LoggedIn/Home/Header/View.elm105
-rw-r--r--src/client/LoggedIn/Home/Model.elm44
-rw-r--r--src/client/LoggedIn/Home/Msg.elm13
-rw-r--r--src/client/LoggedIn/Home/Update.elm44
-rw-r--r--src/client/LoggedIn/Home/View.elm43
-rw-r--r--src/client/LoggedIn/Home/View/ExceedingPayers.elm45
-rw-r--r--src/client/LoggedIn/Home/View/Paging.elm109
-rw-r--r--src/client/LoggedIn/Home/View/Table.elm167
-rw-r--r--src/client/LoggedIn/Income/Table.elm128
-rw-r--r--src/client/LoggedIn/Income/View.elm104
-rw-r--r--src/client/LoggedIn/Model.elm38
-rw-r--r--src/client/LoggedIn/Msg.elm26
-rw-r--r--src/client/LoggedIn/Stat/Model.elm34
-rw-r--r--src/client/LoggedIn/Stat/Msg.elm7
-rw-r--r--src/client/LoggedIn/Stat/Update.elm24
-rw-r--r--src/client/LoggedIn/Stat/View.elm77
-rw-r--r--src/client/LoggedIn/Update.elm137
-rw-r--r--src/client/LoggedIn/View.elm33
-rw-r--r--src/client/LoggedIn/View/Format.elm37
-rw-r--r--src/client/Main.elm26
-rw-r--r--src/client/Main.hs41
-rw-r--r--src/client/Model.elm72
-rw-r--r--src/client/Model/Category.elm35
-rw-r--r--src/client/Model/Conf.elm13
-rw-r--r--src/client/Model/Date.elm15
-rw-r--r--src/client/Model/Frequency.elm36
-rw-r--r--src/client/Model/Income.elm101
-rw-r--r--src/client/Model/Init.elm31
-rw-r--r--src/client/Model/InitResult.elm28
-rw-r--r--src/client/Model/Payer.elm137
-rw-r--r--src/client/Model/Payment.elm117
-rw-r--r--src/client/Model/PaymentCategory.elm61
-rw-r--r--src/client/Model/Size.elm17
-rw-r--r--src/client/Model/Translations.elm68
-rw-r--r--src/client/Model/User.elm44
-rw-r--r--src/client/Model/View.elm12
-rw-r--r--src/client/Msg.elm49
-rw-r--r--src/client/Page.elm43
-rw-r--r--src/client/Server.elm115
-rw-r--r--src/client/SignIn/Model.elm17
-rw-r--r--src/client/SignIn/Msg.elm9
-rw-r--r--src/client/SignIn/Update.elm31
-rw-r--r--src/client/SignIn/View.elm63
-rw-r--r--src/client/Tooltip.elm113
-rw-r--r--src/client/Update.elm182
-rw-r--r--src/client/Utils/Cmd.elm16
-rw-r--r--src/client/Utils/Dict.elm11
-rw-r--r--src/client/Utils/Either.elm9
-rw-r--r--src/client/Utils/Form.elm11
-rw-r--r--src/client/Utils/Http.elm39
-rw-r--r--src/client/Utils/Json.elm12
-rw-r--r--src/client/Utils/List.elm36
-rw-r--r--src/client/Utils/Search.elm10
-rw-r--r--src/client/Utils/String.elm38
-rw-r--r--src/client/Validation.elm65
-rw-r--r--src/client/View.elm34
-rw-r--r--src/client/View/App.hs44
-rw-r--r--src/client/View/Color.elm12
-rw-r--r--src/client/View/Date.elm57
-rw-r--r--src/client/View/Errors.elm21
-rw-r--r--src/client/View/Events.elm15
-rw-r--r--src/client/View/Form.elm152
-rw-r--r--src/client/View/Header.elm60
-rw-r--r--src/client/View/Header.hs86
-rw-r--r--src/client/View/Payment.hs33
-rw-r--r--src/client/View/Payment/Table.hs90
-rw-r--r--src/client/View/Plural.elm11
-rw-r--r--src/client/View/SignIn.hs86
90 files changed, 529 insertions, 4479 deletions
diff --git a/src/client/Chart/Api.elm b/src/client/Chart/Api.elm
deleted file mode 100644
index 693f362..0000000
--- a/src/client/Chart/Api.elm
+++ /dev/null
@@ -1,41 +0,0 @@
-module Chart.Api exposing
- ( from
- , withSize
- , withTitle
- , withOrdinate
- , toHtml
- )
-
-import Html exposing (Html)
-import Svg exposing (..)
-import Svg.Attributes exposing (..)
-
-import Chart.Model as Chart exposing (Chart, Serie, Vec2, View)
-import Chart.View as Chart
-
-from : List String -> List Serie -> Chart
-from keys series =
- { keys = keys
- , series = series
- , size = { x = 600, y = 400 }
- , title = ""
- , scaleColor = "#DDDDDD"
- , formatOrdinate = toString
- , ordinateLines = 5
- }
-
-withSize : Vec2 -> Chart -> Chart
-withSize size chart = { chart | size = size }
-
-withTitle : String -> Chart -> Chart
-withTitle title chart = { chart | title = title }
-
-withOrdinate : Int -> (Float -> String) -> Chart -> Chart
-withOrdinate lines format chart =
- { chart
- | formatOrdinate = format
- , ordinateLines = lines
- }
-
-toHtml : Chart -> Html msg
-toHtml chart = Chart.view chart
diff --git a/src/client/Chart/Model.elm b/src/client/Chart/Model.elm
deleted file mode 100644
index b5c176f..0000000
--- a/src/client/Chart/Model.elm
+++ /dev/null
@@ -1,73 +0,0 @@
-module Chart.Model exposing
- ( Chart
- , Serie
- , maxScale
- , Vec2
- , View
- , mkView
- , bounds
- )
-
-import List.Extra as List
-
-type alias Chart =
- { keys : List String
- , series : List Serie
- , size : Vec2
- , title : String
- , scaleColor : String
- , formatOrdinate : Float -> String
- , ordinateLines : Int
- }
-
-type alias Serie =
- { values : List Float
- , color : String
- , label : String
- }
-
-maxScale : Chart -> Float
-maxScale { keys, series } =
- List.range 0 (List.length keys - 1)
- |> List.map (\i ->
- series
- |> List.map (truncate << Maybe.withDefault 0 << List.getAt i << .values)
- |> List.maximum
- |> Maybe.withDefault 0
- )
- |> List.maximum
- |> Maybe.withDefault 0
- |> upperBound
-
-upperBound : Int -> Float
-upperBound n = toFloat (upperBoundInt 0 n)
-
-upperBoundInt : Int -> Int -> Int
-upperBoundInt count n =
- if n < 10
- then
- (n + 1) * (10 ^ count)
- else
- upperBoundInt (count + 1) (n // 10)
-
-type alias Vec2 =
- { x : Float
- , y : Float
- }
-
-type alias View =
- { fx : Float -> Float
- , fy : Float -> Float
- }
-
-mkView : Vec2 -> Vec2 -> View
-mkView p1 p2 =
- { fx = \x -> p1.x + x * (p2.x - p1.x)
- , fy = \y -> p1.y + y * (p2.y - p1.y)
- }
-
-bounds : View -> (Vec2, Vec2)
-bounds { fx, fy } =
- ( { x = fx 0, y = fy 0 }
- , { x = fx 1, y = fy 1 }
- )
diff --git a/src/client/Chart/View.elm b/src/client/Chart/View.elm
deleted file mode 100644
index af8b4b7..0000000
--- a/src/client/Chart/View.elm
+++ /dev/null
@@ -1,182 +0,0 @@
-module Chart.View exposing
- ( view
- )
-
-import Html exposing (Html)
-import List.Extra as List
-import Svg exposing (..)
-import Svg.Attributes exposing (..)
-
-import Chart.Model as Chart exposing (Chart, Serie, Vec2, View)
-import Utils.List as List
-
-view : Chart -> Html msg
-view chart =
- let { size, title, series } = chart
- titleHeight = 100
- captionHeight = 50
- in svg
- [ width << toString <| size.x
- , height << toString <| size.y
- , viewBox ("0 0 " ++ (toString size.x) ++ " " ++ (toString size.y))
- ]
- ( [ renderTitle (Chart.mkView { x = 0, y = 0 } { x = size.x, y = titleHeight }) title ]
- ++ renderSeriesAndScales (Chart.mkView { x = 50, y = titleHeight } { x = size.x, y = size.y - captionHeight }) chart
- ++ renderCaptions (Chart.mkView { x = 0, y = size.y - captionHeight } { x = size.x, y = size.y }) series
- )
-
-renderTitle : View -> String -> Svg msg
-renderTitle view title =
- text_
- [ x << toString <| view.fx 0.5
- , y << toString <| view.fy 0.5
- , textAnchor "middle"
- , dominantBaseline "middle"
- , fontSize "20"
- ]
- [ text title ]
-
-renderSeriesAndScales : View -> Chart -> List (Svg msg)
-renderSeriesAndScales view chart =
- let { keys, series, scaleColor, formatOrdinate } = chart
- (p1, p2) = Chart.bounds view
- ordinateWidth = 100
- abscissaHeight = 60
- maxScale = Chart.maxScale chart
- in ( renderOrdinates (Chart.mkView { x = p1.x, y = p1.y } { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight }) formatOrdinate maxScale
- ++ renderAbscissas (Chart.mkView { x = p1.x + ordinateWidth, y = p2.y - abscissaHeight } { x = p2.x, y = p2.y }) keys scaleColor
- ++ renderSeries (Chart.mkView { x = p1.x + ordinateWidth, y = p1.y } { x = p2.x, y = p2.y - abscissaHeight }) series maxScale scaleColor
- )
-
-renderOrdinates : View -> (Float -> String) -> Float -> List (Svg msg)
-renderOrdinates view formatOrdinate maxScale =
- ordinates
- |> List.map (\l ->
- text_
- [ x << toString <| view.fx 0.5
- , y << toString <| view.fy l
- , textAnchor "middle"
- , dominantBaseline "middle"
- ]
- [ text << formatOrdinate <| (1 - l) * maxScale ]
- )
-
-
-renderAbscissas : View -> List String -> String -> List (Svg msg)
-renderAbscissas view keys scaleColor =
- let count = List.length keys
- in ( abscissasXPositions keys
- |> List.map (\(xPos, key) ->
- [ text_
- [ x << toString <| view.fx xPos
- , y << toString <| view.fy 0.5
- , textAnchor "middle"
- , dominantBaseline "middle"
- ]
- [ text key ]
- , line
- [ x1 << toString <| view.fx xPos
- , y1 << toString <| view.fy 0
- , x2 << toString <| view.fx xPos
- , y2 << toString <| view.fy 0.2
- , stroke scaleColor
- ]
- []
- ]
- )
- |> List.concat
- )
-
-renderSeries : View -> List Serie -> Float -> String -> List (Svg msg)
-renderSeries view series maxScale scaleColor =
- ( renderHorizontalLines view series scaleColor
- ++ renderPoints view series maxScale
- )
-
-renderHorizontalLines : View -> List Serie -> String -> List (Svg msg)
-renderHorizontalLines view series scaleColor =
- ordinates
- |> List.map (\l ->
- line
- [ x1 << toString <| view.fx 0
- , y1 << toString <| view.fy l
- , x2 << toString <| view.fx 1
- , y2 << toString <| view.fy l
- , stroke scaleColor
- ]
- []
- )
-
-renderPoints : View -> List Serie -> Float -> List (Svg msg)
-renderPoints view series maxScale =
- series
- |> List.map (\serie ->
- let points =
- abscissasXPositions serie.values
- |> List.map (\(xPos, value) -> { x = xPos, y = 1 - value / maxScale })
- in [ renderLines view serie.color points
- , List.map (renderPoint view serie.color) points
- ]
- |> List.concat
- )
- |> List.concat
-
-renderLines : View -> String -> List Vec2 -> List (Svg msg)
-renderLines view color points =
- List.links points
- |> List.map (\(p1, p2) ->
- line
- [ x1 << toString <| view.fx p1.x
- , y1 << toString <| view.fy p1.y
- , x2 << toString <| view.fx p2.x
- , y2 << toString <| view.fy p2.y
- , stroke color
- ]
- []
- )
-
-renderPoint : View -> String -> Vec2 -> Svg msg
-renderPoint view color pos =
- circle
- [ cx << toString <| view.fx pos.x
- , cy << toString <| view.fy pos.y
- , r "4"
- , fill color
- ]
- []
-
-abscissasXPositions : List a -> List (Float, a)
-abscissasXPositions xs =
- let count = List.length xs
- in xs
- |> List.zip (List.range 1 (count + 1))
- |> List.map (\(i, x) -> (toFloat i / (toFloat count + 1), x))
-
-ordinates : List Float
-ordinates =
- let count = 10
- in List.range 0 (count - 1)
- |> List.map (\l -> toFloat l / (toFloat count - 1))
-
-renderCaptions : View -> List Serie -> List (Svg msg)
-renderCaptions view series =
- let count = List.length series
- in series
- |> List.zip (List.range 1 (List.length series))
- |> List.map (\(i, serie) ->
- renderCaption { x = view.fx (toFloat i / (toFloat count + 1)), y = view.fy 0.5 } serie
- )
- |> List.concat
-
-renderCaption : Vec2 -> Serie -> List (Svg msg)
-renderCaption point { label, color } =
- [ text_
- [ x << toString <| point.x
- , y << toString <| point.y
- , textAnchor "middle"
- , dominantBaseline "middle"
- , fill color
- , fontSize "18"
- ]
- [ text label ]
- ]
diff --git a/src/client/Common b/src/client/Common
new file mode 120000
index 0000000..60d3b0a
--- /dev/null
+++ b/src/client/Common
@@ -0,0 +1 @@
+../common \ No newline at end of file
diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs
new file mode 100644
index 0000000..f21798c
--- /dev/null
+++ b/src/client/Component/Button.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Component.Button
+ ( ButtonIn(..)
+ , buttonInDefault
+ , ButtonOut(..)
+ , 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 Icon
+
+data ButtonIn t m = ButtonIn
+ { _buttonIn_class :: Text
+ , _buttonIn_content :: m ()
+ , _buttonIn_waiting :: Event t Bool
+ }
+
+buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m
+buttonInDefault = ButtonIn
+ { _buttonIn_class = ""
+ , _buttonIn_content = R.blank
+ , _buttonIn_waiting = R.never
+ }
+
+data ButtonOut t = ButtonOut
+ { _buttonOut_clic :: Event t ()
+ }
+
+button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
+button buttonIn = do
+ attr <- R.holdDyn
+ (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)])
+ (fmap
+ (\w -> M.fromList $
+ [ ("type", "button") ]
+ <> if w
+ then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])]
+ else [("class", _buttonIn_class buttonIn)])
+ (_buttonIn_waiting buttonIn))
+ (e, _) <- R.elDynAttr' "button" attr $ do
+ Icon.loading
+ R.divClass "content" $ _buttonIn_content buttonIn
+ return $ ButtonOut
+ { _buttonOut_clic = R.domEvent R.Click e
+ }
diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs
new file mode 100644
index 0000000..7111630
--- /dev/null
+++ b/src/client/Component/Input.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Component.Input
+ ( InputIn(..)
+ , InputOut(..)
+ , input
+ ) where
+
+import Data.Text (Text)
+import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:))
+import qualified Reflex.Dom as R
+
+data InputIn t a b = InputIn
+ { _inputIn_reset :: Event t a
+ , _inputIn_placeHolder :: Text
+ }
+
+data InputOut t = InputOut
+ { _inputOut_value :: Dynamic t Text
+ , _inputOut_enter :: Event t ()
+ }
+
+input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t)
+input inputIn = do
+ let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn)
+ let value = fmap (const "") (_inputIn_reset inputIn)
+ textInput <- R.textInput $ R.def & R.attributes .~ placeHolder
+ & R.setValue .~ value
+ let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+ return $ InputOut
+ { _inputOut_value = R._textInput_value textInput
+ , _inputOut_enter = enter
+ }
diff --git a/src/client/Debug.hs b/src/client/Debug.hs
new file mode 100644
index 0000000..0c5c979
--- /dev/null
+++ b/src/client/Debug.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Debug
+ ( event
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget, Event, Dynamic)
+import qualified Reflex.Dom as R
+
+event :: forall t m a. MonadWidget t m => Text -> Event t a -> m ()
+event name e = do
+ count <- R.count e :: m (Dynamic t Int)
+ let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count
+ R.el "div" $ R.dynText text
diff --git a/src/client/Dialog.elm b/src/client/Dialog.elm
deleted file mode 100644
index a7e059a..0000000
--- a/src/client/Dialog.elm
+++ /dev/null
@@ -1,165 +0,0 @@
-module Dialog exposing
- ( Msg(..)
- , Model
- , Config
- , init
- , update
- , view
- )
-
-import Platform.Cmd exposing (Cmd)
-import Task exposing (Task)
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
--- Model
-
-type alias Model model modelMsg msg =
- { config : Maybe (Config model msg)
- , mapMsg : Msg model modelMsg msg -> msg
- , model : model
- }
-
-type alias Config model msg =
- { className : String
- , title : String
- , body : model -> Html msg
- , confirm : String
- , confirmMsg : model -> msg
- , undo : String
- }
-
-init : model -> (Msg model modelMsg msg -> msg) -> Model model modelMsg msg
-init model mapMsg =
- { config = Nothing
- , mapMsg = mapMsg
- , model = model
- }
-
--- Update
-
-type Msg model modelMsg msg =
- NoOp
- | Update modelMsg
- | UpdateAndClose msg
- | OpenWithUpdate (Config model msg) modelMsg
- | Open (Config model msg)
- | Close
-
-update : (modelMsg -> model -> (model, Cmd modelMsg)) -> Msg model modelMsg msg -> model -> Model model modelMsg msg -> (Model model modelMsg msg, Cmd msg)
-update updateModel msg baseModel model =
- case msg of
- NoOp ->
- ( model
- , Cmd.none
- )
-
- Update modelMsg ->
- case updateModel modelMsg baseModel of
- (newModel, effects) ->
- ( { model | model = newModel }
- , Cmd.map (model.mapMsg << Update) effects
- )
-
- UpdateAndClose msg ->
- ( { model | config = Nothing }
- , Task.perform (always msg) (Task.succeed msg)
- )
-
- OpenWithUpdate config modelMsg ->
- case updateModel modelMsg baseModel of
- (newModel, effects) ->
- ( { model
- | model = newModel
- , config = Just config
- }
- , Cmd.map (model.mapMsg << Update) effects
- )
-
- Open config ->
- ( { model | config = Just config }
- , Cmd.none
- )
-
- Close ->
- ( { model | config = Nothing }
- , Cmd.none
- )
-
--- View
-
-view : Model model modelMsg msg -> Html msg
-view { mapMsg, config, model } =
- let isVisible =
- case config of
- Just _ -> True
- Nothing -> False
- in div
- [ class "dialog" ]
- [ curtain mapMsg isVisible
- , case config of
- Nothing ->
- text ""
- Just c ->
- dialog model mapMsg c
- ]
-
-curtain : (Msg model modelMsg msg -> msg) -> Bool -> Html msg
-curtain mapMsg isVisible =
- div
- [ class "curtain"
- , style
- [ ("position", "fixed")
- , ("top", "0")
- , ("left", "0")
- , ("width", "100%")
- , ("height", "100%")
- , ("background-color", "rgba(0, 0, 0, 0.5)")
- , ("z-index", if isVisible then "1000" else "-1")
- , ("opacity", if isVisible then "1" else "0")
- , ("transition", "all 0.2s ease")
- ]
- , onClick (mapMsg Close)
- ]
- []
-
-dialog : model -> (Msg model modelMsg msg -> msg) -> Config model msg -> Html msg
-dialog model mapMsg { className, title, body, confirm, confirmMsg, undo } =
- div
- [ class ("content " ++ className)
- , style
- [ ("position", "fixed")
- , ("top", "25%")
- , ("left", "50%")
- , ("transform", "translate(-50%, -25%)")
- , ("z-index", "1000")
- , ("background-color", "white")
- , ("padding", "20px")
- , ("border-radius", "5px")
- , ("box-shadow", "0px 0px 15px rgba(0, 0, 0, 0.5)")
- ]
- ]
- [ h1 [] [ text title ]
- , body model
- , div
- [ style
- [ ("float", "right")
- ]
- ]
- [ button
- [ class "confirm"
- , onClick (confirmMsg model)
- , style
- [ ("margin-right", "15px")
- ]
- ]
- [ text confirm ]
- , button
- [ class "undo"
- , onClick (mapMsg Close)
- ]
- [ text undo ]
- ]
- ]
diff --git a/src/client/Dialog/AddCategory/Model.elm b/src/client/Dialog/AddCategory/Model.elm
deleted file mode 100644
index 3b70482..0000000
--- a/src/client/Dialog/AddCategory/Model.elm
+++ /dev/null
@@ -1,54 +0,0 @@
-module Dialog.AddCategory.Model exposing
- ( Model
- , init
- , initialAdd
- , initialClone
- , initialEdit
- , validation
- )
-
-import Date exposing (Date)
-import Dict
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Form.Validate as Validate exposing (Validation)
-
-import Model.Category exposing (Categories, Category, CategoryId)
-import Model.Translations exposing (Translations)
-import Validation
-import View.Date as Date
-
-type alias Model =
- { id : Maybe CategoryId
- , name : String
- , color : String
- }
-
-init : Form String Model
-init = Form.initial [] validation
-
-initialAdd : Translations -> List (String, Field)
-initialAdd translations =
- [ ("color", Field.string "#000000")
- ]
-
-initialClone : Translations -> Category -> List (String, Field)
-initialClone translations category =
- [ ("name", Field.string category.name)
- , ("color", Field.string category.color)
- ]
-
-initialEdit : Translations -> CategoryId -> Category -> List (String, Field)
-initialEdit translations categoryId category =
- [ ("id", Field.string (toString categoryId))
- , ("name", Field.string category.name)
- , ("color", Field.string category.color)
- ]
-
-validation : Validation String Model
-validation =
- Validate.map3 Model
- (Validate.field "id" (Validate.maybe Validate.int))
- (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty))
- (Validate.field "color" Validation.color)
diff --git a/src/client/Dialog/AddCategory/View.elm b/src/client/Dialog/AddCategory/View.elm
deleted file mode 100644
index dc55b60..0000000
--- a/src/client/Dialog/AddCategory/View.elm
+++ /dev/null
@@ -1,72 +0,0 @@
-module Dialog.AddCategory.View exposing
- ( button
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-import Task
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Utils.Form as Form
-
-import Dialog
-import Dialog.AddCategory.Model as AddCategory
-import Dialog.Msg as DialogMsg
-
-import Tooltip
-
-import View.Form as Form
-import View.Events exposing (onSubmitPrevDefault)
-
-import Msg exposing (Msg)
-import LoggedIn.Msg as LoggedInMsg
-import LoggedIn.Home.Msg as HomeMsg
-
-import Model.Translations exposing (getMessage)
-import Model.View exposing (View(LoggedInView))
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Home.Model as HomeModel
-
-button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg
-button loggedData initialForm title buttonContent tooltip =
- let dialogConfig =
- { className = "categoryDialog"
- , title = getMessage loggedData.translations title
- , body = \model -> addCategoryForm loggedData model.addCategory
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = submitForm << .addCategory
- , undo = getMessage loggedData.translations "Undo"
- }
- in Html.button
- ( ( case tooltip of
- Just message -> Tooltip.show Msg.Tooltip message
- Nothing -> []
- )
- ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "categoryname" (DialogMsg.AddCategoryMsg (Form.Reset initialForm)))) ]
- )
- [ buttonContent ]
-
-addCategoryForm : LoggedData -> Form String AddCategory.Model -> Html Msg
-addCategoryForm loggedData addCategory =
- let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddCategoryMsg)
- in Html.form
- [ onSubmitPrevDefault Msg.NoOp ]
- [ htmlMap <| Form.textInput loggedData.translations addCategory "category" "name"
- , htmlMap <| Form.colorInput loggedData.translations addCategory "category" "color"
- , Form.hiddenSubmit (submitForm addCategory)
- ]
-
-submitForm : Form String AddCategory.Model -> Msg
-submitForm addCategory =
- case Form.getOutput addCategory of
- Just data ->
- case data.id of
- Just categoryId ->
- Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditCategory categoryId (String.trim data.name) data.color
- Nothing ->
- Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateCategory (String.trim data.name) data.color
- Nothing ->
- Msg.Dialog <| Dialog.Update <| DialogMsg.AddCategoryMsg <| Form.Submit
diff --git a/src/client/Dialog/AddIncome/Model.elm b/src/client/Dialog/AddIncome/Model.elm
deleted file mode 100644
index 5e2ccf1..0000000
--- a/src/client/Dialog/AddIncome/Model.elm
+++ /dev/null
@@ -1,53 +0,0 @@
-module Dialog.AddIncome.Model exposing
- ( Model
- , init
- , initialAdd
- , initialClone
- , initialEdit
- , validation
- )
-
-import Date exposing (Date)
-import View.Date as Date
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Form.Validate as Validate exposing (Validation)
-import Validation
-
-import Model.Translations exposing (Translations)
-import Model.Income exposing (Income, IncomeId)
-
-type alias Model =
- { id : Maybe IncomeId
- , amount : Int
- , date : Date
- }
-
-init : Form String Model
-init = Form.initial [] validation
-
-initialAdd : Translations -> Date -> List (String, Field)
-initialAdd translations date =
- [ ("date", Field.string (Date.shortView date translations))
- ]
-
-initialClone : Translations -> Date -> Income -> List (String, Field)
-initialClone translations date income =
- [ ("amount", Field.string (toString income.amount))
- , ("date", Field.string (Date.shortView date translations))
- ]
-
-initialEdit : Translations -> IncomeId -> Income -> List (String, Field)
-initialEdit translations incomeId income =
- [ ("id", Field.string (toString incomeId))
- , ("amount", Field.string (toString income.amount))
- , ("date", Field.string (Date.shortView (Date.fromTime income.time) translations))
- ]
-
-validation : Validation String Model
-validation =
- Validate.map3 Model
- (Validate.field "id" (Validate.maybe Validate.int))
- (Validate.field "amount" (Validate.int |> Validate.andThen (Validate.minInt 0)))
- (Validate.field "date" Validation.date)
diff --git a/src/client/Dialog/AddIncome/View.elm b/src/client/Dialog/AddIncome/View.elm
deleted file mode 100644
index b413308..0000000
--- a/src/client/Dialog/AddIncome/View.elm
+++ /dev/null
@@ -1,72 +0,0 @@
-module Dialog.AddIncome.View exposing
- ( button
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-import Task
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Utils.Form as Form
-
-import Dialog
-import Dialog.AddIncome.Model as AddIncome
-import Dialog.Msg as DialogMsg
-
-import Tooltip
-
-import View.Form as Form
-import View.Events exposing (onSubmitPrevDefault)
-
-import Msg exposing (Msg)
-import LoggedIn.Msg as LoggedInMsg
-import LoggedIn.Home.Msg as HomeMsg
-
-import Model.Translations exposing (getMessage)
-import Model.View exposing (View(LoggedInView))
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Home.Model as HomeModel
-
-button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg
-button loggedData initialForm title buttonContent tooltip =
- let dialogConfig =
- { className = "incomeDialog"
- , title = getMessage loggedData.translations title
- , body = \model -> addIncomeForm loggedData model.addIncome
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = submitForm << .addIncome
- , undo = getMessage loggedData.translations "Undo"
- }
- in Html.button
- ( ( case tooltip of
- Just message -> Tooltip.show Msg.Tooltip message
- Nothing -> []
- )
- ++ [ onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "incomeamount" (DialogMsg.AddIncomeMsg <| Form.Reset initialForm))) ]
- )
- [ buttonContent ]
-
-addIncomeForm : LoggedData -> Form String AddIncome.Model -> Html Msg
-addIncomeForm loggedData addIncome =
- let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddIncomeMsg)
- in Html.form
- [ onSubmitPrevDefault Msg.NoOp ]
- [ htmlMap <| Form.textInput loggedData.translations addIncome "income" "amount"
- , htmlMap <| Form.textInput loggedData.translations addIncome "income" "date"
- , Form.hiddenSubmit (submitForm addIncome)
- ]
-
-submitForm : Form String AddIncome.Model -> Msg
-submitForm addIncome =
- case Form.getOutput addIncome of
- Just data ->
- case data.id of
- Just incomeId ->
- Msg.Dialog <| Dialog.UpdateAndClose <| Msg.EditIncome incomeId data.amount data.date
- Nothing ->
- Msg.Dialog <| Dialog.UpdateAndClose <| Msg.CreateIncome data.amount data.date
- Nothing ->
- Msg.Dialog <| Dialog.Update <| DialogMsg.AddIncomeMsg <| Form.Submit
diff --git a/src/client/Dialog/AddPayment/Model.elm b/src/client/Dialog/AddPayment/Model.elm
deleted file mode 100644
index 07e7cbb..0000000
--- a/src/client/Dialog/AddPayment/Model.elm
+++ /dev/null
@@ -1,70 +0,0 @@
-module Dialog.AddPayment.Model exposing
- ( Model
- , init
- , initialAdd
- , initialClone
- , initialEdit
- , validation
- )
-
-import Date exposing (Date)
-import View.Date as Date
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Form.Validate as Validate exposing (Validation)
-import Validation
-
-import Model.Category as Category exposing (Categories, CategoryId)
-import Model.Frequency as Frequency
-import Model.Payment as Payment exposing (Payment, PaymentId)
-import Model.Frequency exposing (Frequency)
-import Model.Translations exposing (Translations)
-
-type alias Model =
- { id : Maybe PaymentId
- , name : String
- , cost : Int
- , date : Date
- , category : CategoryId
- , frequency : Frequency
- }
-
-init : Form String Model
-init = Form.initial [] (validation Category.empty)
-
-initialAdd : Translations -> Date -> Frequency -> List (String, Field)
-initialAdd translations date frequency =
- [ ("date", Field.string (Date.shortView date translations))
- , ("frequency", Field.string (toString frequency))
- , ("category", Field.string "")
- ]
-
-initialClone : Translations -> Date -> Maybe CategoryId -> Payment -> List (String, Field)
-initialClone translations date category payment =
- [ ("name", Field.string payment.name)
- , ("cost", Field.string (toString payment.cost))
- , ("date", Field.string (Date.shortView date translations))
- , ("frequency", Field.string (toString payment.frequency))
- , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault ""))
- ]
-
-initialEdit : Translations -> Maybe CategoryId -> Payment -> List (String, Field)
-initialEdit translations category payment =
- [ ("id", Field.string (toString payment.id))
- , ("name", Field.string payment.name)
- , ("cost", Field.string (toString payment.cost))
- , ("date", Field.string (Date.shortView payment.date translations))
- , ("frequency", Field.string (toString payment.frequency))
- , ("category", Field.string (Maybe.map toString category |> Maybe.withDefault ""))
- ]
-
-validation : Categories -> Validation String Model
-validation categories =
- Validate.map6 Model
- (Validate.field "id" (Validate.maybe Validate.int))
- (Validate.field "name" (Validate.string |> Validate.andThen Validate.nonEmpty))
- (Validate.field "cost" Validation.cost)
- (Validate.field "date" Validation.date)
- (Validate.field "category" (Validation.category categories))
- (Validate.field "frequency" Frequency.validate)
diff --git a/src/client/Dialog/AddPayment/View.elm b/src/client/Dialog/AddPayment/View.elm
deleted file mode 100644
index 584adcd..0000000
--- a/src/client/Dialog/AddPayment/View.elm
+++ /dev/null
@@ -1,95 +0,0 @@
-module Dialog.AddPayment.View exposing
- ( button
- )
-
-import Dict
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-import Task
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Utils.Form as Form
-
-import Dialog
-import Dialog.AddPayment.Model as AddPayment
-import Dialog.Msg as DialogMsg
-
-import Tooltip
-
-import View.Events exposing (onSubmitPrevDefault)
-import View.Form as Form
-
-import LoggedIn.Home.Msg as HomeMsg
-import LoggedIn.Msg as LoggedInMsg
-import Msg exposing (Msg)
-
-import Model.Category exposing (Categories)
-import Model.Frequency exposing (Frequency(..))
-import Model.PaymentCategory exposing (PaymentCategories)
-import Model.Translations exposing (getMessage)
-import Model.View exposing (View(LoggedInView))
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Home.Model as HomeModel
-
-button : LoggedData -> List (String, Field) -> String -> Html Msg -> Maybe String -> Html Msg
-button loggedData initialForm title buttonContent tooltip =
- let dialogConfig =
- { className = "paymentDialog"
- , title = getMessage loggedData.translations title
- , body = \model -> addPaymentForm loggedData model.addPayment
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = submitForm loggedData.categories loggedData.paymentCategories << .addPayment
- , undo = getMessage loggedData.translations "Undo"
- }
- in Html.button
- ( ( case tooltip of
- Just message -> Tooltip.show Msg.Tooltip message
- Nothing -> []
- )
- ++ [ class "addPayment"
- , onClick (Msg.Dialog <| Dialog.OpenWithUpdate dialogConfig (DialogMsg.Init "paymentname" (DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories <| Form.Reset initialForm)))
- ]
- )
- [ buttonContent ]
-
-addPaymentForm : LoggedData -> Form String AddPayment.Model -> Html Msg
-addPaymentForm loggedData addPayment =
- let htmlMap = Html.map (Msg.Dialog << Dialog.Update << DialogMsg.AddPaymentMsg loggedData.categories loggedData.paymentCategories)
- categoryOptions =
- loggedData.categories
- |> Dict.toList
- |> List.sortBy (.name << Tuple.second)
- |> List.map (\(id, category) -> (toString id, category.name))
- in Html.form
- [ class "addPayment"
- , onSubmitPrevDefault Msg.NoOp
- ]
- [ htmlMap <| Form.textInput loggedData.translations addPayment "payment" "name"
- , htmlMap <| Form.textInput loggedData.translations addPayment "payment" "cost"
- , if (Form.getFieldAsString "frequency" addPayment).value == Just (toString Punctual)
- then htmlMap <| Form.textInput loggedData.translations addPayment "payment" "date"
- else text ""
- , htmlMap <| Form.selectInput loggedData.translations addPayment "payment" "category" categoryOptions
-
- , htmlMap <| Form.radioInputs loggedData.translations addPayment "payment" "frequency" [ toString Punctual, toString Monthly ]
- , Form.hiddenSubmit (submitForm loggedData.categories loggedData.paymentCategories addPayment)
- ]
-
-submitForm : Categories -> PaymentCategories -> Form String AddPayment.Model -> Msg
-submitForm categories paymentCategories addPayment =
- case Form.getOutput addPayment of
- Just data ->
- case data.id of
- Just paymentId ->
- Msg.Dialog
- <| Dialog.UpdateAndClose
- <| Msg.EditPayment paymentId (String.trim data.name) data.cost data.date data.category data.frequency
- Nothing ->
- Msg.Dialog
- <| Dialog.UpdateAndClose
- <| Msg.CreatePayment (String.trim data.name) data.cost data.date data.category data.frequency
- Nothing ->
- Msg.Dialog <| Dialog.Update <| DialogMsg.AddPaymentMsg categories paymentCategories <| Form.Submit
diff --git a/src/client/Dialog/Model.elm b/src/client/Dialog/Model.elm
deleted file mode 100644
index ff8bc57..0000000
--- a/src/client/Dialog/Model.elm
+++ /dev/null
@@ -1,23 +0,0 @@
-module Dialog.Model exposing
- ( Model
- , init
- )
-
-import Form exposing (Form)
-
-import Dialog.AddPayment.Model as AddPayment
-import Dialog.AddIncome.Model as AddIncome
-import Dialog.AddCategory.Model as AddCategory
-
-type alias Model =
- { addPayment : Form String AddPayment.Model
- , addIncome : Form String AddIncome.Model
- , addCategory : Form String AddCategory.Model
- }
-
-init : Model
-init =
- { addPayment = AddPayment.init
- , addIncome = AddIncome.init
- , addCategory = AddCategory.init
- }
diff --git a/src/client/Dialog/Msg.elm b/src/client/Dialog/Msg.elm
deleted file mode 100644
index 68ed146..0000000
--- a/src/client/Dialog/Msg.elm
+++ /dev/null
@@ -1,15 +0,0 @@
-module Dialog.Msg exposing
- ( Msg(..)
- )
-
-import Form exposing (Form)
-
-import Model.Category exposing (Categories)
-import Model.PaymentCategory exposing (PaymentCategories)
-
-type Msg =
- NoOp
- | Init String Msg
- | AddPaymentMsg Categories PaymentCategories Form.Msg
- | AddIncomeMsg Form.Msg
- | AddCategoryMsg Form.Msg
diff --git a/src/client/Dialog/Update.elm b/src/client/Dialog/Update.elm
deleted file mode 100644
index 3915548..0000000
--- a/src/client/Dialog/Update.elm
+++ /dev/null
@@ -1,74 +0,0 @@
-module Dialog.Update exposing
- ( update
- )
-
-import Dom exposing (Id)
-import Form exposing (Form)
-import Form.Field as Field
-import Task
-
-import Dialog.AddCategory.Model as AddCategory
-import Dialog.AddIncome.Model as AddIncome
-import Dialog.AddPayment.Model as AddPayment
-import Dialog.Model as Dialog
-import Dialog.Msg as Dialog
-
-import Model.Category exposing (Categories)
-import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories)
-
-update : Dialog.Msg -> Dialog.Model -> (Dialog.Model, Cmd Dialog.Msg)
-update msg model =
- case msg of
-
- Dialog.NoOp ->
- ( model
- , Cmd.none
- )
-
- Dialog.Init inputId dialogMsg ->
- update dialogMsg model
- |> Tuple.mapSecond (\cmd -> Cmd.batch [cmd, inputFocus inputId])
-
- Dialog.AddPaymentMsg categories paymentCategories formMsg ->
- ( { model
- | addPayment =
- Form.update (AddPayment.validation categories) formMsg model.addPayment
- |> updateCategory categories paymentCategories formMsg
- }
- , Cmd.none
- )
-
- Dialog.AddIncomeMsg formMsg ->
- ( { model
- | addIncome = Form.update AddIncome.validation formMsg model.addIncome
- }
- , Cmd.none
- )
-
- Dialog.AddCategoryMsg formMsg ->
- ( { model
- | addCategory = Form.update AddCategory.validation formMsg model.addCategory
- }
- , Cmd.none
- )
-
-inputFocus : Id -> Cmd Dialog.Msg
-inputFocus id =
- Dom.focus id
- |> Task.map (always Dialog.NoOp)
- |> Task.onError (\_ -> Task.succeed Dialog.NoOp)
- |> Task.perform (always Dialog.NoOp)
-
-updateCategory : Categories -> PaymentCategories -> Form.Msg -> (Form String AddPayment.Model -> Form String AddPayment.Model)
-updateCategory categories paymentCategories formMsg =
- case formMsg of
- Form.Input "name" Form.Text (Field.String paymentName) ->
- case PaymentCategory.search paymentName paymentCategories of
- Just category ->
- Form.update
- (AddPayment.validation categories)
- (Form.Input "category" Form.Text (Field.String <| toString category))
- Nothing ->
- identity
- _ ->
- identity
diff --git a/src/client/Icon.hs b/src/client/Icon.hs
new file mode 100644
index 0000000..7223def
--- /dev/null
+++ b/src/client/Icon.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Icon
+ ( loading
+ , signOut
+ , clone
+ , edit
+ , delete
+ ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+loading :: forall t m. MonadWidget t m => m ()
+loading =
+ svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $
+ svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank
+
+signOut :: forall t m. MonadWidget t m => m ()
+signOut =
+ svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+ svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank
+
+clone :: forall t m. MonadWidget t m => m ()
+clone =
+ svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+ svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank
+
+edit :: forall t m. MonadWidget t m => m ()
+edit =
+ svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+ svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank
+
+delete :: forall t m. MonadWidget t m => m ()
+delete =
+ svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $
+ svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank
+
+svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a
+svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child
diff --git a/src/client/Init.elm b/src/client/Init.elm
deleted file mode 100644
index d87e870..0000000
--- a/src/client/Init.elm
+++ /dev/null
@@ -1,30 +0,0 @@
-module Init exposing
- ( Init
- , decoder
- )
-
-import Time exposing (..)
-
-import Json.Decode as Decode exposing (Decoder)
-
-import Model.Translations exposing (..)
-import Model.Conf exposing (..)
-import Model.InitResult exposing (..)
-import Model.Size exposing (..)
-
-type alias Init =
- { time : Time
- , translations : Translations
- , conf : Conf
- , result : InitResult
- , windowSize : Size
- }
-
-decoder : Decoder Init
-decoder =
- Decode.map5 Init
- (Decode.field "time" Decode.float)
- (Decode.field "translations" translationsDecoder)
- (Decode.field "conf" confDecoder)
- (Decode.field "result" initResultDecoder)
- (Decode.field "windowSize" sizeDecoder)
diff --git a/src/client/LoggedData.elm b/src/client/LoggedData.elm
deleted file mode 100644
index e048247..0000000
--- a/src/client/LoggedData.elm
+++ /dev/null
@@ -1,44 +0,0 @@
-module LoggedData exposing
- ( LoggedData
- , build
- )
-
-import Time exposing (Time)
-
-import Msg exposing (Msg)
-
-import Model exposing (Model)
-import Model.Translations exposing (..)
-import Model.Conf exposing (..)
-import Model.Payment exposing (Payments)
-import Model.User exposing (Users, UserId)
-import Model.Income exposing (Incomes)
-import Model.Category exposing (Categories)
-import Model.PaymentCategory exposing (PaymentCategories)
-
-import LoggedIn.Model as LoggedInModel
-
-type alias LoggedData =
- { currentTime : Time
- , translations : Translations
- , conf : Conf
- , users : Users
- , me : UserId
- , payments : Payments
- , incomes : Incomes
- , categories : Categories
- , paymentCategories : PaymentCategories
- }
-
-build : Time -> Translations -> Conf -> LoggedInModel.Model -> LoggedData
-build currentTime translations conf loggedIn =
- { currentTime = currentTime
- , translations = translations
- , conf = conf
- , users = loggedIn.users
- , me = loggedIn.me
- , payments = loggedIn.payments
- , incomes = loggedIn.incomes
- , categories = loggedIn.categories
- , paymentCategories = loggedIn.paymentCategories
- }
diff --git a/src/client/LoggedIn/Category/Table.elm b/src/client/LoggedIn/Category/Table.elm
deleted file mode 100644
index 9405e57..0000000
--- a/src/client/LoggedIn/Category/Table.elm
+++ /dev/null
@@ -1,123 +0,0 @@
-module LoggedIn.Category.Table exposing
- ( view
- )
-
-import Dict exposing (..)
-import Date exposing (Date)
-import String exposing (append)
-
-import FontAwesome
-import View.Color as Color
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import Dialog
-import Dialog.AddCategory.Model as AddCategory
-import Dialog.AddCategory.View as AddCategory
-
-import Tooltip
-
-import Msg exposing (Msg)
-
-import LoggedData exposing (LoggedData)
-
-import LoggedIn.Msg as LoggedInMsg
-
-import View.Date as Date
-import LoggedIn.View.Format as Format
-
-import Model.User exposing (getUserName)
-import Model.Category as Category exposing (CategoryId, Category)
-import Model.PaymentCategory as PaymentCategory
-import Model.Translations exposing (getMessage)
-
-view : LoggedData -> Html Msg
-view loggedData =
- let categories =
- loggedData.categories
- |> Dict.toList
- |> List.sortBy (.name << Tuple.second)
- in div
- [ class "table" ]
- [ div
- [ class "lines" ]
- ( headerLine loggedData :: List.map (paymentLine loggedData) categories)
- , if List.isEmpty (Dict.toList loggedData.categories)
- then
- div
- [ class "emptyTableMsg" ]
- [ text <| getMessage loggedData.translations "NoCategories" ]
- else
- text ""
- ]
-
-headerLine : LoggedData -> Html Msg
-headerLine loggedData =
- div
- [ class "header" ]
- [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ]
- , div [ class "cell category" ] [ text <| getMessage loggedData.translations "Color" ]
- , div [ class "cell" ] []
- , div [ class "cell" ] []
- , div [ class "cell" ] []
- ]
-
-paymentLine : LoggedData -> (CategoryId, Category) -> Html Msg
-paymentLine loggedData (categoryId, category) =
- div
- [ class "row" ]
- [ div
- [ class "cell category" ]
- [ text category.name ]
- , div
- [ class "cell category" ]
- [ span
- [ class "tag"
- , style [("background-color", category.color)]
- ]
- [ text category.color ]
- ]
- , div
- [ class "cell button" ]
- [ let currentDate = Date.fromTime loggedData.currentTime
- in AddCategory.button
- loggedData
- (AddCategory.initialClone loggedData.translations category)
- "CloneCategory"
- (FontAwesome.clone Color.chestnutRose 18)
- (Just (getMessage loggedData.translations "Clone"))
- ]
- , div
- [ class "cell button" ]
- [ AddCategory.button
- loggedData
- (AddCategory.initialEdit loggedData.translations categoryId category)
- "EditCategory"
- (FontAwesome.pencil Color.chestnutRose 18)
- (Just (getMessage loggedData.translations "Edit"))
- ]
- , div
- [ class "cell button" ]
- [ if PaymentCategory.isCategoryUnused categoryId loggedData.paymentCategories
- then
- let dialogConfig =
- { className = "deleteCategoryDialog"
- , title = getMessage loggedData.translations "ConfirmCategoryDelete"
- , body = always <| text ""
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteCategory categoryId
- , undo = getMessage loggedData.translations "Undo"
- }
- in button
- ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete")
- ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ]
- )
- [ FontAwesome.trash Color.chestnutRose 18 ]
- else
- span
- ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "UsedCategory") )
- [ FontAwesome.trash Color.silver 18 ]
- ]
- ]
diff --git a/src/client/LoggedIn/Category/View.elm b/src/client/LoggedIn/Category/View.elm
deleted file mode 100644
index bba51b7..0000000
--- a/src/client/LoggedIn/Category/View.elm
+++ /dev/null
@@ -1,34 +0,0 @@
-module LoggedIn.Category.View exposing
- ( view
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-
-import LoggedData exposing (LoggedData)
-
-import Msg exposing (Msg)
-
-import Dialog.AddCategory.Model as AddCategory
-import Dialog.AddCategory.View as AddCategory
-
-import LoggedIn.Category.Table as Table
-
-import Model.Translations exposing (getMessage, getParamMessage)
-
-view : LoggedData -> Html Msg
-view loggedData =
- div
- [ class "categories" ]
- [ div
- [ class "titleButton withMargin" ]
- [ h1 [] [ text <| getMessage loggedData.translations "Categories" ]
- , AddCategory.button
- loggedData
- (AddCategory.initialAdd loggedData.translations)
- "AddCategory"
- (text (getMessage loggedData.translations "AddCategory"))
- Nothing
- ]
- , Table.view loggedData
- ]
diff --git a/src/client/LoggedIn/Home/Header/View.elm b/src/client/LoggedIn/Home/Header/View.elm
deleted file mode 100644
index 14d90d7..0000000
--- a/src/client/LoggedIn/Home/Header/View.elm
+++ /dev/null
@@ -1,105 +0,0 @@
-module LoggedIn.Home.Header.View exposing
- ( view
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-import String
-import Dict
-import Date
-
-import Form exposing (Form)
-import View.Form as Form
-import View.Events exposing (onSubmitPrevDefault)
-
-import Msg exposing (Msg)
-import LoggedIn.Msg as LoggedInMsg
-import LoggedIn.Home.Msg as HomeMsg
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Home.Model as Home
-import Model.Translations exposing (getParamMessage)
-import Model.Conf exposing (Conf)
-import Model.Payment as Payment exposing (Payments)
-import Model.Frequency exposing (Frequency(..))
-import Model.Translations exposing (getMessage)
-
-import Dialog.AddPayment.Model as AddPayment
-import Dialog.AddPayment.View as AddPayment
-
-import LoggedIn.Home.View.ExceedingPayers as ExceedingPayers
-import LoggedIn.View.Format as Format
-import View.Plural exposing (plural)
-
-view : LoggedData -> Home.Model -> Payments -> Frequency -> Html Msg
-view loggedData { search } payments frequency =
- let currentDate = Date.fromTime loggedData.currentTime
- in Html.div
- [ class "header" ]
- [ div
- [ class "payerAndAdd" ]
- [ ExceedingPayers.view loggedData
- , AddPayment.button
- loggedData
- (AddPayment.initialAdd loggedData.translations currentDate frequency)
- "AddPayment"
- (text (getMessage loggedData.translations "AddPayment"))
- Nothing
- ]
- , Html.div
- [ class "searchLine" ]
- [ searchForm loggedData search ]
- , infos loggedData payments
- ]
-
-searchForm : LoggedData -> Form String Home.Search -> Html Msg
-searchForm loggedData search =
- Html.map (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.SearchMsg) <|
- Html.form
- [ onSubmitPrevDefault Form.NoOp ]
- [ Form.textInput loggedData.translations search "search" "name"
- , if List.isEmpty (Payment.monthly loggedData.payments)
- then text ""
- else Form.radioInputs loggedData.translations search "search" "frequency" [ toString Punctual, toString Monthly ]
- ]
-
-infos : LoggedData -> Payments -> Html Msg
-infos loggedData payments =
- let paymentsCount = List.length payments
- in if paymentsCount == 0
- then text ""
- else
- let count = plural loggedData.translations (List.length payments) "Payment" "Payments"
- sum = paymentsSum loggedData.conf payments
- in div
- [ class "infos" ]
- [ span
- [ class "total" ]
- [ text <| getParamMessage [ count, sum ] loggedData.translations "Worth" ]
- , span
- [ class "partition" ]
- [ text <| paymentsPartition loggedData payments ]
- ]
-
-paymentsPartition : LoggedData -> Payments -> String
-paymentsPartition loggedData payments =
- String.join
- ", "
- ( loggedData.users
- |> Dict.toList
- |> List.map (Tuple.mapFirst (\userId -> Payment.totalPayments (always True) userId payments))
- |> List.filter (\(sum, _) -> sum > 0)
- |> List.sortBy Tuple.first
- |> List.reverse
- |> List.map (\(sum, user) ->
- getParamMessage [ user.name, Format.price loggedData.conf sum ] loggedData.translations "By"
- )
- )
-
-paymentsSum : Conf -> Payments -> String
-paymentsSum conf payments =
- payments
- |> List.map .cost
- |> List.sum
- |> Format.price conf
diff --git a/src/client/LoggedIn/Home/Model.elm b/src/client/LoggedIn/Home/Model.elm
deleted file mode 100644
index e5381f6..0000000
--- a/src/client/LoggedIn/Home/Model.elm
+++ /dev/null
@@ -1,44 +0,0 @@
-module LoggedIn.Home.Model exposing
- ( Model
- , Search
- , init
- , searchInitial
- , validation
- )
-
-import Form exposing (Form)
-import Form.Field as Field exposing (Field)
-import Form.Validate as Validate exposing (Validation)
-
-import Model.Frequency as Frequency
-import Model.Payer exposing (Payers)
-import Model.Payment as Payment exposing (PaymentId, Payments)
-import Model.Frequency exposing (Frequency(..))
-import Model.User exposing (Users, UserId)
-
-type alias Model =
- { punctualPage : Int
- , monthlyPage : Int
- , search : Form String Search
- }
-
-type alias Search =
- { name : Maybe String
- , frequency : Frequency
- }
-
-init : Model
-init =
- { punctualPage = 1
- , monthlyPage = 1
- , search = Form.initial (searchInitial Punctual) validation
- }
-
-searchInitial : Frequency -> List (String, Field)
-searchInitial frequency = [ ("frequency", Field.string (toString frequency)) ]
-
-validation : Validation String Search
-validation =
- Validate.map2 Search
- (Validate.field "name" (Validate.maybe Validate.string))
- (Validate.field "frequency" Frequency.validate)
diff --git a/src/client/LoggedIn/Home/Msg.elm b/src/client/LoggedIn/Home/Msg.elm
deleted file mode 100644
index 69f15ad..0000000
--- a/src/client/LoggedIn/Home/Msg.elm
+++ /dev/null
@@ -1,13 +0,0 @@
-module LoggedIn.Home.Msg exposing
- ( Msg(..)
- )
-
-import Form exposing (Form)
-
-import Model.Payment exposing (PaymentId)
-import Model.Frequency exposing (Frequency)
-
-type Msg =
- NoOp
- | UpdatePage Int
- | SearchMsg Form.Msg
diff --git a/src/client/LoggedIn/Home/Update.elm b/src/client/LoggedIn/Home/Update.elm
deleted file mode 100644
index 06c2c7e..0000000
--- a/src/client/LoggedIn/Home/Update.elm
+++ /dev/null
@@ -1,44 +0,0 @@
-module LoggedIn.Home.Update exposing
- ( update
- )
-
-import Form exposing (Form)
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Home.Model as Home
-import LoggedIn.Home.Msg as Home
-import Model.Frequency as Frequency exposing (Frequency(..))
-
-update : LoggedData -> Home.Msg -> Home.Model -> (Home.Model, Cmd Home.Msg)
-update loggedData msg model =
- case msg of
-
- Home.NoOp ->
- ( model
- , Cmd.none
- )
-
- Home.UpdatePage page ->
- ( updatePage page model
- , Cmd.none
- )
-
- Home.SearchMsg formMsg ->
- let newModel =
- case formMsg of
- Form.Input "name" _ _ -> updatePage 1 model
- _ -> model
- in ( { model | search = Form.update Home.validation formMsg model.search }
- , Cmd.none
- )
-
-updatePage : Int -> Home.Model -> Home.Model
-updatePage page model =
- let frequency =
- Form.getFieldAsString "frequency" model.search
- |> .value
- |> Maybe.andThen Frequency.fromString
- in case frequency of
- Just Punctual -> { model | punctualPage = page }
- Just Monthly -> { model | monthlyPage = page }
- Nothing -> model
diff --git a/src/client/LoggedIn/Home/View.elm b/src/client/LoggedIn/Home/View.elm
deleted file mode 100644
index fba3f7c..0000000
--- a/src/client/LoggedIn/Home/View.elm
+++ /dev/null
@@ -1,43 +0,0 @@
-module LoggedIn.Home.View exposing
- ( view
- )
-
-import Date
-import Html exposing (..)
-import Html.Attributes exposing (..)
-
-import Form
-import Utils.Form as Form
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Home.Header.View as Header
-import LoggedIn.Home.Model as Home
-import LoggedIn.Home.Msg as HomeMsg
-import LoggedIn.Home.View.Paging as Paging
-import LoggedIn.Home.View.Table as Table
-import LoggedIn.Msg as LoggedInMsg
-import Model.Payment as Payment
-import Model.Frequency exposing (Frequency(..))
-import Msg exposing (Msg)
-
-view : LoggedData -> Home.Model -> Html Msg
-view loggedData home =
- let (name, frequency) =
- case Form.getOutput home.search of
- Just data -> (Maybe.withDefault "" data.name, data.frequency)
- Nothing -> ("", Punctual)
- payments = Payment.search name frequency loggedData.payments
- page =
- case frequency of
- Punctual -> home.punctualPage
- Monthly -> home.monthlyPage
- in div
- [ class "home" ]
- [ Header.view loggedData home payments frequency
- , Table.view loggedData home payments frequency page
- , Paging.view
- page
- (List.length payments)
- Msg.NoOp
- (Msg.UpdateLoggedIn << LoggedInMsg.HomeMsg << HomeMsg.UpdatePage)
- ]
diff --git a/src/client/LoggedIn/Home/View/ExceedingPayers.elm b/src/client/LoggedIn/Home/View/ExceedingPayers.elm
deleted file mode 100644
index 6f2439c..0000000
--- a/src/client/LoggedIn/Home/View/ExceedingPayers.elm
+++ /dev/null
@@ -1,45 +0,0 @@
-module LoggedIn.Home.View.ExceedingPayers exposing
- ( view
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-
-import Msg exposing (Msg)
-
-import LoggedData exposing (LoggedData)
-
-import LoggedIn.View.Format as Format
-
-import Model exposing (Model)
-import Model.User exposing (getUserName)
-import Model.Payment as Payment
-import Model.Payer exposing (..)
-import Model.Translations exposing (getMessage)
-
-view : LoggedData -> Html Msg
-view loggedData =
- let payments = Payment.punctual loggedData.payments
- exceedingPayers = getOrderedExceedingPayers loggedData.currentTime loggedData.users loggedData.incomes payments
- in div
- [ class "exceedingPayers" ]
- ( if List.isEmpty exceedingPayers
- then [ text <| getMessage loggedData.translations "PaymentsAreBalanced" ]
- else (List.map (exceedingPayer loggedData) exceedingPayers)
- )
-
-exceedingPayer : LoggedData -> ExceedingPayer -> Html Msg
-exceedingPayer loggedData payer =
- span
- [ class "exceedingPayer" ]
- [ span
- [ class "userName" ]
- [ payer.userId
- |> getUserName loggedData.users
- |> Maybe.withDefault "−"
- |> text
- ]
- , span
- [ class "amount" ]
- [ text ("+ " ++ (Format.price loggedData.conf payer.amount)) ]
- ]
diff --git a/src/client/LoggedIn/Home/View/Paging.elm b/src/client/LoggedIn/Home/View/Paging.elm
deleted file mode 100644
index dffe061..0000000
--- a/src/client/LoggedIn/Home/View/Paging.elm
+++ /dev/null
@@ -1,109 +0,0 @@
-module LoggedIn.Home.View.Paging exposing
- ( view
- )
-
-import Color exposing (Color)
-
-import FontAwesome
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import LoggedData exposing (LoggedData)
-import Model.Payment as Payment exposing (Payments, perPage)
-
-showedPages : Int
-showedPages = 5
-
-view : Int -> Int -> msg -> (Int -> msg) -> Html msg
-view currentPage payments noOp pageMsg =
- let maxPage = ceiling (toFloat payments / toFloat perPage)
- pages = truncatePages currentPage (List.range 1 maxPage)
- in if maxPage <= 1
- then
- text ""
- else
- div
- [ class "pages" ]
- ( [ firstPage currentPage pageMsg
- , previousPage currentPage noOp pageMsg
- ]
- ++ ( List.map (paymentsPage currentPage noOp pageMsg) pages)
- ++ [ nextPage currentPage maxPage noOp pageMsg
- , lastPage currentPage maxPage pageMsg
- ]
- )
-
-truncatePages : Int -> List Int -> List Int
-truncatePages currentPage pages =
- let totalPages = List.length pages
- showedLeftPages = ceiling ((toFloat showedPages - 1) / 2)
- showedRightPages = floor ((toFloat showedPages - 1) / 2)
- truncatedPages =
- if currentPage <= showedLeftPages then
- (List.range 1 showedPages)
- else if currentPage > totalPages - showedRightPages then
- (List.range (totalPages - showedPages + 1) totalPages)
- else
- (List.range (currentPage - showedLeftPages) (currentPage + showedRightPages))
- in List.filter (flip List.member pages) truncatedPages
-
-firstPage : Int -> (Int -> msg) -> Html msg
-firstPage currentPage pageMsg =
- button
- [ classList
- [ ("page", True)
- , ("disable", currentPage <= 1)
- ]
- , onClick (pageMsg 1)
- ]
- [ FontAwesome.fast_backward grey 13 ]
-
-previousPage : Int -> msg -> (Int -> msg) -> Html msg
-previousPage currentPage noOp pageMsg =
- button
- [ class "page"
- , onClick <|
- if currentPage > 1
- then (pageMsg <| currentPage - 1)
- else noOp
- ]
- [ FontAwesome.backward grey 13 ]
-
-nextPage : Int -> Int -> msg -> (Int -> msg) -> Html msg
-nextPage currentPage maxPage noOp pageMsg =
- button
- [ class "page"
- , onClick <|
- if currentPage < maxPage
- then (pageMsg <| currentPage + 1)
- else noOp
- ]
- [ FontAwesome.forward grey 13 ]
-
-lastPage : Int -> Int -> (Int -> msg) -> Html msg
-lastPage currentPage maxPage pageMsg =
- button
- [ class "page"
- , onClick (pageMsg maxPage)
- ]
- [ FontAwesome.fast_forward grey 13 ]
-
-paymentsPage : Int -> msg -> (Int -> msg) -> Int -> Html msg
-paymentsPage currentPage noOp pageMsg page =
- let onCurrentPage = page == currentPage
- in button
- [ classList
- [ ("page", True)
- , ("current", onCurrentPage)
- ]
- , onClick <|
- if onCurrentPage
- then noOp
- else pageMsg page
- ]
- [ text (toString page) ]
-
-grey : Color
-grey = Color.greyscale 0.35
diff --git a/src/client/LoggedIn/Home/View/Table.elm b/src/client/LoggedIn/Home/View/Table.elm
deleted file mode 100644
index f94bb19..0000000
--- a/src/client/LoggedIn/Home/View/Table.elm
+++ /dev/null
@@ -1,167 +0,0 @@
-module LoggedIn.Home.View.Table exposing
- ( view
- )
-
-import Date exposing (Date)
-import Dict exposing (..)
-import String exposing (append)
-
-import FontAwesome
-import View.Color as Color
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import Dialog
-import Dialog.AddPayment.Model as AddPayment
-import Dialog.AddPayment.View as AddPayment
-
-import Tooltip
-
-import Msg exposing (Msg)
-
-import LoggedData exposing (LoggedData)
-
-import LoggedIn.Msg as LoggedInMsg
-
-import LoggedIn.Home.Model as Home
-import LoggedIn.View.Format as Format
-import View.Date as Date
-
-import Model.Payment as Payment exposing (..)
-import Model.Frequency exposing (Frequency(..))
-import Model.PaymentCategory as PaymentCategory
-import Model.Translations exposing (getMessage)
-import Model.User exposing (getUserName)
-
-view : LoggedData -> Home.Model -> Payments -> Frequency -> Int -> Html Msg
-view loggedData homeModel payments frequency page =
- let visiblePayments =
- payments
- |> List.drop ((page - 1) * perPage)
- |> List.take perPage
- in div
- [ class "table" ]
- [ div
- [ class "lines" ]
- ( headerLine loggedData frequency :: List.map (paymentLine loggedData homeModel frequency) visiblePayments )
- , if List.isEmpty visiblePayments
- then
- div
- [ class "emptyTableMsg" ]
- [ text <| getMessage loggedData.translations "NoPayment" ]
- else
- text ""
- ]
-
-headerLine : LoggedData -> Frequency -> Html Msg
-headerLine loggedData frequency =
- div
- [ class "header" ]
- [ div [ class "cell category" ] [ text <| getMessage loggedData.translations "Name" ]
- , div [ class "cell cost" ] [ text <| getMessage loggedData.translations "Cost" ]
- , div [ class "cell user" ] [ text <| getMessage loggedData.translations "Payer" ]
- , div [ class "cell user" ] [ text <| getMessage loggedData.translations "PaymentCategory" ]
- , case frequency of
- Punctual -> div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ]
- Monthly -> text ""
- , div [ class "cell" ] []
- , div [ class "cell" ] []
- , div [ class "cell" ] []
- ]
-
-paymentLine : LoggedData -> Home.Model -> Frequency -> Payment -> Html Msg
-paymentLine loggedData homeModel frequency payment =
- div
- [ class "row" ]
- [ div [ class "cell name" ] [ text payment.name ]
- , div
- [ classList
- [ ("cell cost", True)
- , ("refund", payment.cost < 0)
- ]
- ]
- [ text (Format.price loggedData.conf payment.cost) ]
- , div
- [ class "cell user" ]
- [ payment.userId
- |> getUserName loggedData.users
- |> Maybe.withDefault "−"
- |> text
- ]
- , div
- [ class "cell category" ]
- ( let mbCategory =
- PaymentCategory.search payment.name loggedData.paymentCategories
- |> Maybe.andThen (\category -> Dict.get category loggedData.categories)
- in case mbCategory of
- Just category ->
- [ span
- [ class "tag"
- , style [("background-color", category.color)]
- ]
- [ text category.name ]
- ]
- Nothing ->
- []
- )
- , case frequency of
- Punctual ->
- div
- [ class "cell date" ]
- [ span
- [ class "shortDate" ]
- [ text (Date.shortView payment.date loggedData.translations) ]
- , span
- [ class "longDate" ]
- [ text (Date.longView payment.date loggedData.translations) ]
- ]
- Monthly ->
- text ""
- , div
- [ class "cell button" ]
- [ let currentDate = Date.fromTime loggedData.currentTime
- category = PaymentCategory.search payment.name loggedData.paymentCategories
- in AddPayment.button
- loggedData
- (AddPayment.initialClone loggedData.translations currentDate category payment)
- "ClonePayment"
- (FontAwesome.clone Color.chestnutRose 18)
- (Just (getMessage loggedData.translations "Clone"))
- ]
- , div
- [ class "cell button" ]
- [ if loggedData.me /= payment.userId
- then
- text ""
- else
- let category = PaymentCategory.search payment.name loggedData.paymentCategories
- in AddPayment.button
- loggedData
- (AddPayment.initialEdit loggedData.translations category payment)
- "EditPayment"
- (FontAwesome.pencil Color.chestnutRose 18)
- (Just (getMessage loggedData.translations "Edit"))
- ]
- , div
- [ class "cell button" ]
- [ if loggedData.me /= payment.userId
- then
- text ""
- else
- let dialogConfig =
- { className = "deletePaymentDialog"
- , title = getMessage loggedData.translations "ConfirmPaymentDelete"
- , body = always <| text ""
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeletePayment payment.id
- , undo = getMessage loggedData.translations "Undo"
- }
- in button
- ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete")
- ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ]
- )
- [ FontAwesome.trash Color.chestnutRose 18 ]
- ]
- ]
diff --git a/src/client/LoggedIn/Income/Table.elm b/src/client/LoggedIn/Income/Table.elm
deleted file mode 100644
index f10a552..0000000
--- a/src/client/LoggedIn/Income/Table.elm
+++ /dev/null
@@ -1,128 +0,0 @@
-module LoggedIn.Income.Table exposing
- ( view
- )
-
-import Dict exposing (..)
-import Date exposing (Date)
-import String exposing (append)
-
-import FontAwesome
-import View.Color as Color
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import Dialog
-import Dialog.AddIncome.Model as AddIncome
-import Dialog.AddIncome.View as AddIncome
-
-import Tooltip
-
-import Msg exposing (Msg)
-
-import LoggedData exposing (LoggedData)
-
-import LoggedIn.Msg as LoggedInMsg
-
-import View.Date as Date
-import LoggedIn.View.Format as Format
-
-import Model.User exposing (getUserName)
-import Model.Income as Income exposing (..)
-import Model.Translations exposing (getMessage)
-
-view : LoggedData -> Html Msg
-view loggedData =
- let incomes =
- loggedData.incomes
- |> Dict.toList
- |> List.sortBy (.time << Tuple.second)
- |> List.reverse
- in div
- [ class "table" ]
- [ div
- [ class "lines" ]
- ( headerLine loggedData :: List.map (paymentLine loggedData) incomes)
- , if List.isEmpty (Dict.toList loggedData.incomes)
- then
- div
- [ class "emptyTableMsg" ]
- [ text <| getMessage loggedData.translations "NoIncome" ]
- else
- text ""
- ]
-
-headerLine : LoggedData -> Html Msg
-headerLine loggedData =
- div
- [ class "header" ]
- [ div [ class "cell name" ] [ text <| getMessage loggedData.translations "Name" ]
- , div [ class "cell income" ] [ text <| getMessage loggedData.translations "Income" ]
- , div [ class "cell date" ] [ text <| getMessage loggedData.translations "Date" ]
- , div [ class "cell" ] []
- , div [ class "cell" ] []
- , div [ class "cell" ] []
- ]
-
-paymentLine : LoggedData -> (IncomeId, Income) -> Html Msg
-paymentLine loggedData (incomeId, income) =
- div
- [ class "row" ]
- [ div
- [ class "cell name" ]
- [ income.userId
- |> getUserName loggedData.users
- |> Maybe.withDefault "−"
- |> text
- ]
- , div
- [ class "cell income" ]
- [ text (Format.price loggedData.conf income.amount) ]
- , div
- [ class "cell date" ]
- [ text (Date.longView (Date.fromTime income.time) loggedData.translations) ]
- , div
- [ class "cell button" ]
- [ let currentDate = Date.fromTime loggedData.currentTime
- in AddIncome.button
- loggedData
- (AddIncome.initialClone loggedData.translations currentDate income)
- "CloneIncome"
- (FontAwesome.clone Color.chestnutRose 18)
- (Just (getMessage loggedData.translations "Clone"))
- ]
- , div
- [ class "cell button" ]
- [ if loggedData.me /= income.userId
- then
- text ""
- else
- AddIncome.button
- loggedData
- (AddIncome.initialEdit loggedData.translations incomeId income)
- "EditIncome"
- (FontAwesome.pencil Color.chestnutRose 18)
- (Just (getMessage loggedData.translations "Edit"))
- ]
- , div
- [ class "cell button" ]
- [ if loggedData.me /= income.userId
- then
- text ""
- else
- let dialogConfig =
- { className = "deleteIncomeDialog"
- , title = getMessage loggedData.translations "ConfirmIncomeDelete"
- , body = always <| text ""
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId
- , undo = getMessage loggedData.translations "Undo"
- }
- in button
- ( Tooltip.show Msg.Tooltip (getMessage loggedData.translations "Delete")
- ++ [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ]
- )
- [ FontAwesome.trash Color.chestnutRose 18 ]
- ]
- ]
diff --git a/src/client/LoggedIn/Income/View.elm b/src/client/LoggedIn/Income/View.elm
deleted file mode 100644
index 85b0dc3..0000000
--- a/src/client/LoggedIn/Income/View.elm
+++ /dev/null
@@ -1,104 +0,0 @@
-module LoggedIn.Income.View exposing
- ( view
- )
-
-import Dict
-import Date
-import Time exposing (Time)
-import Task
-
-import FontAwesome
-
-import Html exposing (..)
-import Html.Events exposing (..)
-import Html.Attributes exposing (..)
-
-import Form exposing (Form)
-import View.Form as Form
-import View.Events exposing (onSubmitPrevDefault)
-
-import Dialog
-import Dialog.AddIncome.Model as AddIncome
-import Dialog.AddIncome.View as AddIncome
-
-import Msg exposing (Msg)
-
-import LoggedData exposing (LoggedData)
-
-import Model.Income exposing (IncomeId, Income, userCumulativeIncomeSince)
-import Model.Translations exposing (getMessage, getParamMessage)
-import Model.Payer exposing (useIncomesFrom)
-import Model.User exposing (UserId, User)
-import Model.View as View
-
-import View.Date as Date
-import LoggedIn.View.Format as Format
-import View.Color as Color
-import LoggedIn.Income.Table as Table
-
-view : LoggedData -> Html Msg
-view loggedData =
- div
- [ class "income" ]
- [ div
- [ class "withMargin" ]
- [ case useIncomesFrom loggedData.users loggedData.incomes loggedData.payments of
- Just since -> cumulativeIncomesView loggedData since
- Nothing -> text ""
- , div
- [ class "titleButton" ]
- [ h1 [] [ text <| getMessage loggedData.translations "MonthlyNetIncomes" ]
- , AddIncome.button
- loggedData
- (AddIncome.initialAdd loggedData.translations (Date.fromTime loggedData.currentTime))
- "AddIncome"
- (text (getMessage loggedData.translations "AddIncome"))
- Nothing
- ]
- ]
- , Table.view loggedData
- ]
-
-cumulativeIncomesView : LoggedData -> Time -> Html Msg
-cumulativeIncomesView loggedData since =
- let longDate = Date.longView (Date.fromTime since) loggedData.translations
- in div
- []
- [ h1 [] [ text <| getParamMessage [longDate] loggedData.translations "CumulativeIncomesSince" ]
- , ul
- []
- ( Dict.toList loggedData.users
- |> List.map (\(userId, user) ->
- (user.name, userCumulativeIncomeSince loggedData.currentTime since loggedData.incomes userId)
- )
- |> List.sortBy Tuple.second
- |> List.map (\(userName, cumulativeIncome) ->
- li
- []
- [ text userName
- , text " − "
- , text <| Format.price loggedData.conf cumulativeIncome
- ]
- )
- )
- ]
-
-incomeView : LoggedData -> (IncomeId, Income) -> Html Msg
-incomeView loggedData (incomeId, income) =
- li
- []
- [ text <| Date.shortView (Date.fromTime income.time) loggedData.translations
- , text " − "
- , text <| Format.price loggedData.conf income.amount
- , let dialogConfig =
- { className = "deleteIncomeDialog"
- , title = getMessage loggedData.translations "ConfirmIncomeDelete"
- , body = always <| text ""
- , confirm = getMessage loggedData.translations "Confirm"
- , confirmMsg = always <| Msg.Dialog <| Dialog.UpdateAndClose <| Msg.DeleteIncome incomeId
- , undo = getMessage loggedData.translations "Undo"
- }
- in button
- [ onClick (Msg.Dialog <| Dialog.Open dialogConfig) ]
- [ FontAwesome.trash Color.chestnutRose 14 ]
- ]
diff --git a/src/client/LoggedIn/Model.elm b/src/client/LoggedIn/Model.elm
deleted file mode 100644
index f4fad94..0000000
--- a/src/client/LoggedIn/Model.elm
+++ /dev/null
@@ -1,38 +0,0 @@
-module LoggedIn.Model exposing
- ( Model
- , init
- )
-
-import Time exposing (Time)
-
-import LoggedIn.Home.Model as Home
-import LoggedIn.Stat.Model as Stat
-import Model.Category exposing (Categories)
-import Model.Income exposing (Incomes)
-import Model.Init exposing (..)
-import Model.Payment exposing (Payments)
-import Model.PaymentCategory exposing (PaymentCategories)
-import Model.User exposing (Users, UserId)
-
-type alias Model =
- { home : Home.Model
- , stat : Stat.Model
- , users : Users
- , me : UserId
- , payments : Payments
- , incomes : Incomes
- , categories : Categories
- , paymentCategories : PaymentCategories
- }
-
-init : Time -> Init -> Model
-init time { users, me, payments, incomes, categories, paymentCategories } =
- { home = Home.init
- , stat = Stat.init time paymentCategories payments
- , users = users
- , me = me
- , payments = payments
- , incomes = incomes
- , categories = categories
- , paymentCategories = paymentCategories
- }
diff --git a/src/client/LoggedIn/Msg.elm b/src/client/LoggedIn/Msg.elm
deleted file mode 100644
index d9b3bce..0000000
--- a/src/client/LoggedIn/Msg.elm
+++ /dev/null
@@ -1,26 +0,0 @@
-module LoggedIn.Msg exposing
- ( Msg(..)
- )
-
-import Date exposing (Date)
-
-import LoggedIn.Home.Msg as Home
-import LoggedIn.Stat.Msg as Stat
-import Model.Category exposing (CategoryId)
-import Model.Frequency exposing (Frequency)
-import Model.Income exposing (IncomeId)
-import Model.Payment exposing (PaymentId)
-
-type Msg =
- NoOp
- | HomeMsg Home.Msg
- | StatMsg Stat.Msg
- | ValidateCreatePayment PaymentId String Int Date CategoryId Frequency
- | ValidateEditPayment PaymentId String Int Date CategoryId Frequency
- | ValidateDeletePayment PaymentId
- | ValidateCreateIncome IncomeId Int Date
- | ValidateEditIncome IncomeId Int Date
- | ValidateDeleteIncome IncomeId
- | ValidateCreateCategory CategoryId String String
- | ValidateEditCategory CategoryId String String
- | ValidateDeleteCategory CategoryId
diff --git a/src/client/LoggedIn/Stat/Model.elm b/src/client/LoggedIn/Stat/Model.elm
deleted file mode 100644
index bfc66f2..0000000
--- a/src/client/LoggedIn/Stat/Model.elm
+++ /dev/null
@@ -1,34 +0,0 @@
-module LoggedIn.Stat.Model exposing
- ( Model
- , init
- , getPaymentsByMonthByCategory
- )
-
-import Date exposing (Month)
-import List.Extra as List
-import Time exposing (Time)
-
-import Model.Category exposing (CategoryId)
-import Model.Conf exposing (Conf)
-import Model.Payment as Payment exposing (Payments)
-import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories)
-
-type alias Model =
- { paymentsByMonthByCategory : List ((Month, Int), List (CategoryId, Int))
- }
-
-init : Time -> PaymentCategories -> Payments -> Model
-init currentTime paymentCategories payments =
- { paymentsByMonthByCategory = getPaymentsByMonthByCategory currentTime paymentCategories payments
- }
-
-getPaymentsByMonthByCategory : Time -> PaymentCategories -> Payments -> List ((Month, Int), List (CategoryId, Int))
-getPaymentsByMonthByCategory currentTime paymentCategories payments =
- Payment.punctual payments
- |> Payment.groupAndSortByMonth
- |> List.map (\(m, payments) ->
- ( m
- , PaymentCategory.groupPaymentsByCategory paymentCategories payments
- |> List.map (Tuple.mapSecond (List.sum << List.map .cost))
- )
- )
diff --git a/src/client/LoggedIn/Stat/Msg.elm b/src/client/LoggedIn/Stat/Msg.elm
deleted file mode 100644
index d517544..0000000
--- a/src/client/LoggedIn/Stat/Msg.elm
+++ /dev/null
@@ -1,7 +0,0 @@
-module LoggedIn.Stat.Msg exposing
- ( Msg(..)
- )
-
-type Msg =
- NoOp
- | UpdateChart
diff --git a/src/client/LoggedIn/Stat/Update.elm b/src/client/LoggedIn/Stat/Update.elm
deleted file mode 100644
index 2415733..0000000
--- a/src/client/LoggedIn/Stat/Update.elm
+++ /dev/null
@@ -1,24 +0,0 @@
-module LoggedIn.Stat.Update exposing
- ( update
- )
-
-import LoggedData exposing (LoggedData)
-import LoggedIn.Stat.Model as Stat
-import LoggedIn.Stat.Msg as Stat
-
-update : LoggedData -> Stat.Msg -> Stat.Model -> (Stat.Model, Cmd Stat.Msg)
-update loggedData msg model =
- case msg of
-
- Stat.NoOp ->
- ( model
- , Cmd.none
- )
-
- Stat.UpdateChart ->
- let { currentTime, paymentCategories, payments } = loggedData
- in ( { model
- | paymentsByMonthByCategory = Stat.getPaymentsByMonthByCategory currentTime paymentCategories payments
- }
- , Cmd.none
- )
diff --git a/src/client/LoggedIn/Stat/View.elm b/src/client/LoggedIn/Stat/View.elm
deleted file mode 100644
index e389c67..0000000
--- a/src/client/LoggedIn/Stat/View.elm
+++ /dev/null
@@ -1,77 +0,0 @@
-module LoggedIn.Stat.View exposing
- ( view
- )
-
-import Date exposing (Month)
-import Dict
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import List.Extra as List
-import Time exposing (Time)
-
-import Chart.Api as Chart
-import LoggedData exposing (LoggedData)
-import LoggedIn.Stat.Model as Stat
-import LoggedIn.View.Format as Format
-import Model.Category exposing (CategoryId, Categories)
-import Model.Conf exposing (Conf)
-import Model.Payment as Payment exposing (Payments)
-import Model.PaymentCategory as PaymentCategory exposing (PaymentCategories)
-import Model.Translations exposing (Translations, getMessage, getParamMessage)
-import Msg exposing (Msg)
-import Utils.List as List
-import View.Date as Date
-import View.Plural exposing (plural)
-
-view : LoggedData -> Stat.Model -> Html Msg
-view loggedData { paymentsByMonthByCategory } =
- div
- [ class "stat withMargin" ]
- [ renderChart loggedData paymentsByMonthByCategory ]
-
-renderChart : LoggedData -> List ((Month, Int), List (CategoryId, Int)) -> Html msg
-renderChart { currentTime, paymentCategories, categories, conf, translations } paymentsByMonthByCategory =
- let monthPaymentMean = getMonthPaymentMean currentTime paymentsByMonthByCategory
- title = getParamMessage [ Format.price conf monthPaymentMean ] translations "ByMonthsAndMean"
- keys =
- paymentsByMonthByCategory
- |> List.map (\((month, year), _) -> Date.shortMonthAndYear month year translations)
- series =
- categories
- |> Dict.toList
- |> List.map (\(categoryId, category) ->
- { values =
- List.map
- (\(_, paymentsByCategory) ->
- paymentsByCategory
- |> List.find (\(c, _) -> c == categoryId)
- |> Maybe.map (toFloat << Tuple.second)
- |> Maybe.withDefault 0
- )
- paymentsByMonthByCategory
- , color = category.color
- , label = category.name
- }
- )
- totalSerie =
- { values =
- List.transpose (List.map .values series)
- |> List.map List.sum
- , color = "black"
- , label = getMessage translations "Total"
- }
- in Chart.from keys (series ++ [totalSerie])
- |> Chart.withSize { x = 2000, y = 900 }
- |> Chart.withTitle title
- |> Chart.withOrdinate 10 (Format.price conf << truncate)
- |> Chart.toHtml
-
-getMonthPaymentMean : Time -> List ((Month, Int), List (CategoryId, Int)) -> Int
-getMonthPaymentMean currentTime paymentsByMonthByCategory =
- paymentsByMonthByCategory
- |> List.filter (\((month, year), _) ->
- let currentDate = Date.fromTime currentTime
- in not (Date.month currentDate == month && Date.year currentDate == year)
- )
- |> List.map (List.sum << List.map Tuple.second << Tuple.second)
- |> List.mean
diff --git a/src/client/LoggedIn/Update.elm b/src/client/LoggedIn/Update.elm
deleted file mode 100644
index a1d5f7d..0000000
--- a/src/client/LoggedIn/Update.elm
+++ /dev/null
@@ -1,137 +0,0 @@
-module LoggedIn.Update exposing
- ( update
- )
-
-import Date exposing (Date)
-import Dict
-import Form
-import Http exposing (Error(..))
-import Platform.Cmd exposing (Cmd)
-import String
-import Task
-
-import LoggedData
-import LoggedIn.Home.Model as Home
-import LoggedIn.Home.Msg as Home
-import LoggedIn.Home.Update as Home
-import LoggedIn.Model as LoggedInModel
-import LoggedIn.Msg as LoggedIn
-import LoggedIn.Stat.Model as Stat
-import LoggedIn.Stat.Msg as Stat
-import LoggedIn.Stat.Update as Stat
-import Model exposing (Model)
-import Model.Category exposing (Category)
-import Model.Frequency exposing (Frequency(..))
-import Model.Income as Income exposing (Income)
-import Model.Payment as Payment exposing (Payment)
-import Model.PaymentCategory as PaymentCategory
-import Server
-
-import Utils.Cmd exposing ((:>))
-
-update : Model -> LoggedIn.Msg -> LoggedInModel.Model -> (LoggedInModel.Model, Cmd LoggedIn.Msg)
-update model msg loggedIn =
- let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn
- in case msg of
-
- LoggedIn.NoOp ->
- ( loggedIn
- , Cmd.none
- )
-
- LoggedIn.HomeMsg homeMsg ->
- case Home.update loggedData homeMsg loggedIn.home of
- (home, effects) ->
- ( { loggedIn | home = home }
- , Cmd.map LoggedIn.HomeMsg effects
- )
-
- LoggedIn.StatMsg statMsg ->
- case Stat.update loggedData statMsg loggedIn.stat of
- (stat, effects) ->
- ( { loggedIn | stat = stat }
- , Cmd.map LoggedIn.StatMsg effects
- )
-
- LoggedIn.ValidateCreatePayment paymentId name cost date category frequency ->
- update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial frequency))) loggedIn
- :> update model (LoggedIn.HomeMsg <| Home.UpdatePage 1)
- :> (\loggedIn ->
- let newPayment = Payment paymentId name cost date loggedIn.me frequency
- in ( { loggedIn
- | payments = newPayment :: loggedIn.payments
- , paymentCategories = PaymentCategory.save name category loggedIn.paymentCategories
- }
- , Cmd.none
- )
- )
-
- LoggedIn.ValidateEditPayment paymentId name cost date category frequency ->
- let updatedPayment = Payment paymentId name cost date loggedIn.me frequency
- mbOldPayment = Payment.find paymentId loggedIn.payments
- in ( { loggedIn
- | payments = Payment.edit updatedPayment loggedIn.payments
- , paymentCategories =
- case mbOldPayment of
- Just oldPayment ->
- PaymentCategory.save name category loggedIn.paymentCategories
- Nothing ->
- loggedData.paymentCategories
- }
- , Cmd.none
- )
-
- LoggedIn.ValidateDeletePayment paymentId ->
- let payments = Payment.delete paymentId loggedIn.payments
- frequency =
- case Form.getOutput loggedIn.home.search of
- Just data -> data.frequency
- Nothing -> Punctual
- switchToPunctual =
- ( frequency == Monthly
- && List.isEmpty (Payment.monthly payments)
- )
- in if switchToPunctual
- then
- update model (LoggedIn.HomeMsg <| Home.SearchMsg (Form.Reset (Home.searchInitial Punctual))) loggedIn
- :> (\loggedIn ->
- ( { loggedIn | payments = payments }
- , Cmd.none
- )
- )
- else
- ( { loggedIn | payments = payments }
- , Cmd.none
- )
-
- LoggedIn.ValidateCreateIncome incomeId amount date ->
- let newIncome = { userId = loggedIn.me, amount = amount, time = Date.toTime date }
- in ( { loggedIn | incomes = Dict.insert incomeId newIncome loggedIn.incomes }
- , Cmd.none
- )
-
- LoggedIn.ValidateEditIncome incomeId amount date ->
- let updateIncome _ = Just <| Income loggedIn.me (Date.toTime date) amount
- in ( { loggedIn | incomes = Dict.update incomeId updateIncome loggedIn.incomes }
- , Cmd.none
- )
-
- LoggedIn.ValidateDeleteIncome incomeId ->
- ( { loggedIn | incomes = Dict.remove incomeId loggedIn.incomes }
- , Cmd.none
- )
-
- LoggedIn.ValidateCreateCategory categoryId name color ->
- let newCategory = { name = name, color = color }
- in ( { loggedIn | categories = Dict.insert categoryId newCategory loggedIn.categories }
- , Cmd.none
- )
-
- LoggedIn.ValidateEditCategory categoryId name color ->
- let updateCategory _ = Just <| Category name color
- in ( { loggedIn | categories = Dict.update categoryId updateCategory loggedIn.categories } , Cmd.none)
-
- LoggedIn.ValidateDeleteCategory categoryId ->
- ( { loggedIn | categories = Dict.remove categoryId loggedIn.categories }
- , Cmd.none
- )
diff --git a/src/client/LoggedIn/View.elm b/src/client/LoggedIn/View.elm
deleted file mode 100644
index 4936c6e..0000000
--- a/src/client/LoggedIn/View.elm
+++ /dev/null
@@ -1,33 +0,0 @@
-module LoggedIn.View exposing
- ( view
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-
-import Page
-
-import Msg exposing (Msg)
-import Model exposing (Model)
-import Model.Translations exposing (getMessage)
-import LoggedData
-
-import LoggedIn.Model as LoggedInModel
-
-import LoggedIn.Home.View as Home
-import LoggedIn.Income.View as Income
-import LoggedIn.Category.View as Categories
-import LoggedIn.Stat.View as Stat
-
-view : Model -> LoggedInModel.Model -> Html Msg
-view model loggedIn =
- div
- [ class "loggedIn" ]
- [ let loggedData = LoggedData.build model.currentTime model.translations model.conf loggedIn
- in case model.page of
- Page.Home -> Home.view loggedData loggedIn.home
- Page.Income -> Income.view loggedData
- Page.Categories -> Categories.view loggedData
- Page.Statistics -> Stat.view loggedData loggedIn.stat
- Page.NotFound -> div [] [ text (getMessage model.translations "PageNotFound") ]
- ]
diff --git a/src/client/LoggedIn/View/Format.elm b/src/client/LoggedIn/View/Format.elm
deleted file mode 100644
index f41e2cd..0000000
--- a/src/client/LoggedIn/View/Format.elm
+++ /dev/null
@@ -1,37 +0,0 @@
-module LoggedIn.View.Format exposing
- ( price
- )
-
-import String exposing (..)
-
-import Model.Conf exposing (Conf)
-
-price : Conf -> Int -> String
-price conf amount =
- ( number amount
- ++ " "
- ++ conf.currency
- )
-
-number : Int -> String
-number n =
- abs n
- |> toString
- |> toList
- |> List.reverse
- |> group 3
- |> List.intersperse [' ']
- |> List.concat
- |> List.reverse
- |> fromList
- |> append (if n < 0 then "-" else "")
-
-group : Int -> List a -> List (List a)
-group n xs =
- if List.length xs <= n
- then
- [xs]
- else
- let take = List.take n xs
- drop = List.drop n xs
- in take :: (group n drop)
diff --git a/src/client/Main.elm b/src/client/Main.elm
deleted file mode 100644
index 7981a1c..0000000
--- a/src/client/Main.elm
+++ /dev/null
@@ -1,26 +0,0 @@
-module Main exposing
- ( main
- )
-
-import Navigation
-import Time
-import Msg exposing (Msg(UpdatePage))
-
-import Model exposing (init)
-import Update exposing (update)
-import View exposing (view)
-import Page
-import Tooltip
-
-main =
- Navigation.programWithFlags (UpdatePage << Page.fromLocation)
- { init = init
- , view = view
- , update = update
- , subscriptions = (\model ->
- Sub.batch
- [ Time.every 60000 Msg.UpdateTime
- , Sub.map Msg.Tooltip Tooltip.subscription
- ]
- )
- }
diff --git a/src/client/Main.hs b/src/client/Main.hs
new file mode 100644
index 0000000..c5f2c50
--- /dev/null
+++ b/src/client/Main.hs
@@ -0,0 +1,41 @@
+module Main
+ ( main
+ ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LB
+import Data.JSString.Text (textFromJSString)
+import qualified Data.Text.Encoding as T
+import qualified GHCJS.DOM as Dom
+import qualified GHCJS.DOM.NonElementParentNode as Dom
+import GHCJS.DOM.Types (JSM, Element, JSString)
+import Prelude hiding (init, error)
+
+import Common.Model (InitResult(InitEmpty))
+import qualified Common.Message as Message
+import qualified Common.Message.Key as Key
+
+import qualified View.App as App
+
+main :: JSM ()
+main = do
+ initResult <- readInit
+ putStrLn . show $ initResult
+ App.widget initResult
+
+readInit :: JSM InitResult
+readInit = do
+ document <- Dom.currentDocumentUnchecked
+ initNode <- Dom.getElementById document "init"
+ case initNode of
+ Just node -> do
+ text <- textFromJSString <$> js_getInnerText node
+ return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of
+ Just init -> init
+ Nothing -> initParseError
+ _ ->
+ return initParseError
+ where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError)
+
+foreign import javascript unsafe "$1[\"innerText\"]"
+ js_getInnerText :: Element -> IO JSString
diff --git a/src/client/Model.elm b/src/client/Model.elm
deleted file mode 100644
index 7f62416..0000000
--- a/src/client/Model.elm
+++ /dev/null
@@ -1,72 +0,0 @@
-module Model exposing
- ( Model
- , init
- )
-
-import Time exposing (Time)
-import Json.Decode as Decode
-
-import Navigation exposing (Location)
-
-import Html as Html
-
-import Page exposing (Page)
-import Init as Init exposing (Init)
-import Msg exposing (Msg)
-
-import Model.View exposing (..)
-import Model.Translations exposing (..)
-import Model.Conf exposing (..)
-import Model.InitResult exposing (..)
-import LoggedIn.Model as LoggedInModel
-import SignIn.Model as SignInModel
-
-import Dialog
-import Dialog.Model as DialogModel
-import Dialog.Msg as DialogMsg
-
-import Tooltip
-
-type alias Model =
- { view : View
- , currentTime : Time
- , translations : Translations
- , conf : Conf
- , page : Page
- , errors : List String
- , dialog : Dialog.Model DialogModel.Model DialogMsg.Msg Msg
- , tooltip : Tooltip.Model
- }
-
-init : Decode.Value -> Location -> (Model, Cmd Msg)
-init payload location =
- let model =
- case Decode.decodeValue Init.decoder payload of
- Ok { time, translations, conf, result, windowSize } ->
- { view =
- case result of
- InitEmpty ->
- SignInView (SignInModel.init Nothing)
- InitSuccess init ->
- LoggedInView (LoggedInModel.init time init)
- InitError error ->
- SignInView (SignInModel.init (Just error))
- , currentTime = time
- , translations = translations
- , conf = conf
- , page = Page.fromLocation location
- , errors = []
- , dialog = Dialog.init DialogModel.init Msg.Dialog
- , tooltip = Tooltip.init windowSize.width windowSize.height
- }
- Err error ->
- { view = SignInView (SignInModel.init (Just error))
- , currentTime = 0
- , translations = []
- , conf = { currency = "" }
- , page = Page.fromLocation location
- , errors = [ error ]
- , dialog = Dialog.init DialogModel.init Msg.Dialog
- , tooltip = Tooltip.init 0 0
- }
- in (model, Cmd.none)
diff --git a/src/client/Model/Category.elm b/src/client/Model/Category.elm
deleted file mode 100644
index 8b653a7..0000000
--- a/src/client/Model/Category.elm
+++ /dev/null
@@ -1,35 +0,0 @@
-module Model.Category exposing
- ( Categories
- , Category
- , CategoryId
- , categoriesDecoder
- , categoryIdDecoder
- , empty
- )
-
-import Json.Decode as Decode exposing (Decoder)
-import Utils.Json as Json
-import Dict exposing (Dict)
-
-type alias Categories = Dict CategoryId Category
-
-type alias CategoryId = Int
-
-type alias Category =
- { name : String
- , color : String
- }
-
-categoriesDecoder : Decoder Categories
-categoriesDecoder =
- Json.dictDecoder (Decode.field "id" categoryIdDecoder) <|
- Decode.map2
- Category
- (Decode.field "name" Decode.string)
- (Decode.field "color" Decode.string)
-
-categoryIdDecoder : Decoder CategoryId
-categoryIdDecoder = Decode.int
-
-empty : Categories
-empty = Dict.empty
diff --git a/src/client/Model/Conf.elm b/src/client/Model/Conf.elm
deleted file mode 100644
index 308fa04..0000000
--- a/src/client/Model/Conf.elm
+++ /dev/null
@@ -1,13 +0,0 @@
-module Model.Conf exposing
- ( Conf
- , confDecoder
- )
-
-import Json.Decode as Decode exposing (Decoder)
-
-type alias Conf =
- { currency : String
- }
-
-confDecoder : Decoder Conf
-confDecoder = Decode.map Conf (Decode.field "currency" Decode.string)
diff --git a/src/client/Model/Date.elm b/src/client/Model/Date.elm
deleted file mode 100644
index bfba02f..0000000
--- a/src/client/Model/Date.elm
+++ /dev/null
@@ -1,15 +0,0 @@
-module Model.Date exposing
- ( timeDecoder
- , dateDecoder
- )
-
-import Date as Date exposing (Date)
-import Json.Decode as Decode exposing (Decoder)
-import Json.Decode.Extra as Decode
-import Time exposing (Time)
-
-timeDecoder : Decoder Time
-timeDecoder = Decode.map Date.toTime dateDecoder
-
-dateDecoder : Decoder Date
-dateDecoder = Decode.string |> Decode.andThen (Date.fromString >> Decode.fromResult)
diff --git a/src/client/Model/Frequency.elm b/src/client/Model/Frequency.elm
deleted file mode 100644
index 40f9893..0000000
--- a/src/client/Model/Frequency.elm
+++ /dev/null
@@ -1,36 +0,0 @@
-module Model.Frequency exposing
- ( Frequency(..)
- , decoder
- , validate
- , fromString
- )
-
-import Json.Decode as Decode exposing (Decoder)
-import Json.Decode.Extra as Decode
-
-import Form.Validate as Validate exposing (Validation)
-
-type Frequency = Punctual | Monthly
-
-decoder : Decoder Frequency
-decoder =
- let frequencyResult input =
- fromString input
- |> Result.fromMaybe ("Could not deduce Punctual nor Monthly from " ++ input)
- in Decode.string |> Decode.andThen (Decode.fromResult << frequencyResult)
-
-validate : Validation String Frequency
-validate =
- Validate.customValidation Validate.string (\str ->
- fromString str
- |> Result.fromMaybe (Validate.customError "InvalidFrequency")
- )
-
-fromString : String -> Maybe Frequency
-fromString str =
- if str == toString Punctual then
- Just Punctual
- else if str == toString Monthly then
- Just Monthly
- else
- Nothing
diff --git a/src/client/Model/Income.elm b/src/client/Model/Income.elm
deleted file mode 100644
index aa5f05f..0000000
--- a/src/client/Model/Income.elm
+++ /dev/null
@@ -1,101 +0,0 @@
-module Model.Income exposing
- ( Incomes
- , Income
- , IncomeId
- , incomesDecoder
- , incomeIdDecoder
- , incomeDefinedForAll
- , userCumulativeIncomeSince
- , cumulativeIncomesSince
- )
-
-import Dict exposing (Dict)
-import Json.Decode as Decode exposing (Decoder)
-import List exposing (..)
-import Maybe.Extra as Maybe
-import Time exposing (Time, hour)
-import Utils.Json as Json
-
-import Model.Date exposing (timeDecoder)
-import Model.User exposing (UserId, userIdDecoder)
-
-type alias Incomes = Dict IncomeId Income
-
-type alias IncomeId = Int
-
-type alias Income =
- { userId : UserId
- , time : Float
- , amount : Int
- }
-
-incomesDecoder : Decoder Incomes
-incomesDecoder =
- Json.dictDecoder (Decode.field "id" incomeIdDecoder) <|
- Decode.map3 Income
- (Decode.field "userId" userIdDecoder)
- (Decode.field "date" timeDecoder)
- (Decode.field "amount" Decode.int)
-
-incomeIdDecoder : Decoder IncomeId
-incomeIdDecoder = Decode.int
-
-incomeDefinedForAll : List UserId -> Incomes -> Maybe Time
-incomeDefinedForAll userIds incomes =
- let userIncomes = List.map (\userId -> List.filter ((==) userId << .userId) << Dict.values <| incomes) userIds
- firstIncomes = map (head << sortBy .time) userIncomes
- in if all Maybe.isJust firstIncomes
- then head << reverse << List.sort << map .time << Maybe.values <| firstIncomes
- else Nothing
-
-userCumulativeIncomeSince : Time -> Time -> Incomes -> UserId -> Int
-userCumulativeIncomeSince currentTime since incomes userId =
- incomes
- |> Dict.values
- |> List.filter (\income -> income.userId == userId)
- |> cumulativeIncomesSince currentTime since
-
-cumulativeIncomesSince : Time -> Time -> (List Income) -> Int
-cumulativeIncomesSince currentTime since incomes =
- cumulativeIncome currentTime (getOrderedIncomesSince since incomes)
-
-getOrderedIncomesSince : Time -> List Income -> List Income
-getOrderedIncomesSince time incomes =
- let mbStarterIncome = getIncomeAt time incomes
- orderedIncomesSince = filter (\income -> income.time >= time) incomes
- in (Maybe.toList mbStarterIncome) ++ orderedIncomesSince
-
-getIncomeAt : Time -> List Income -> Maybe Income
-getIncomeAt time incomes =
- case incomes of
- [x] ->
- if x.time < time
- then Just { userId = x.userId, time = time, amount = x.amount }
- else Nothing
- x1 :: x2 :: xs ->
- if x1.time < time && x2.time >= time
- then Just { userId = x1.userId, time = time, amount = x1.amount }
- else getIncomeAt time (x2 :: xs)
- [] ->
- Nothing
-
-cumulativeIncome : Time -> List Income -> Int
-cumulativeIncome currentTime incomes =
- getIncomesWithDuration currentTime (List.sortBy .time incomes)
- |> map durationIncome
- |> sum
-
-getIncomesWithDuration : Time -> List Income -> List (Float, Int)
-getIncomesWithDuration currentTime incomes =
- case incomes of
- [] ->
- []
- [income] ->
- [(currentTime - income.time, income.amount)]
- (income1 :: income2 :: xs) ->
- (income2.time - income1.time, income1.amount) :: (getIncomesWithDuration currentTime (income2 :: xs))
-
-durationIncome : (Float, Int) -> Int
-durationIncome (duration, income) =
- duration * toFloat income / (hour * 24 * 365 / 12)
- |> truncate
diff --git a/src/client/Model/Init.elm b/src/client/Model/Init.elm
deleted file mode 100644
index db7069f..0000000
--- a/src/client/Model/Init.elm
+++ /dev/null
@@ -1,31 +0,0 @@
-module Model.Init exposing
- ( Init
- , initDecoder
- )
-
-import Json.Decode as Decode exposing (Decoder)
-
-import Model.Payment exposing (Payments, paymentsDecoder)
-import Model.User exposing (Users, UserId, usersDecoder, userIdDecoder)
-import Model.Income exposing (Incomes, incomesDecoder)
-import Model.Category exposing (Categories, categoriesDecoder)
-import Model.PaymentCategory exposing (PaymentCategories, paymentCategoriesDecoder)
-
-type alias Init =
- { users : Users
- , me : UserId
- , payments : Payments
- , incomes : Incomes
- , categories : Categories
- , paymentCategories : PaymentCategories
- }
-
-initDecoder : Decoder Init
-initDecoder =
- Decode.map6 Init
- (Decode.field "users" usersDecoder)
- (Decode.field "me" userIdDecoder)
- (Decode.field "payments" paymentsDecoder)
- (Decode.field "incomes" incomesDecoder)
- (Decode.field "categories" categoriesDecoder)
- (Decode.field "paymentCategories" paymentCategoriesDecoder)
diff --git a/src/client/Model/InitResult.elm b/src/client/Model/InitResult.elm
deleted file mode 100644
index 7ce0be2..0000000
--- a/src/client/Model/InitResult.elm
+++ /dev/null
@@ -1,28 +0,0 @@
-module Model.InitResult exposing
- ( InitResult(..)
- , initResultDecoder
- )
-
-import Json.Decode as Decode exposing (Decoder)
-
-import Model.Init exposing (Init, initDecoder)
-
-type InitResult =
- InitEmpty
- | InitSuccess Init
- | InitError String
-
-initResultDecoder : Decoder InitResult
-initResultDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen initResultDecoderWithTag
-
-initResultDecoderWithTag : String -> Decoder InitResult
-initResultDecoderWithTag tag =
- case tag of
- "InitEmpty" ->
- Decode.succeed InitEmpty
- "InitSuccess" ->
- Decode.map InitSuccess (Decode.field "contents" initDecoder)
- "InitError" ->
- Decode.map InitError (Decode.field "contents" Decode.string)
- _ ->
- Decode.fail <| "got " ++ tag ++ " for InitResult"
diff --git a/src/client/Model/Payer.elm b/src/client/Model/Payer.elm
deleted file mode 100644
index 4d9190e..0000000
--- a/src/client/Model/Payer.elm
+++ /dev/null
@@ -1,137 +0,0 @@
-module Model.Payer exposing
- ( Payers
- , Payer
- , ExceedingPayer
- , getOrderedExceedingPayers
- , useIncomesFrom
- )
-
-import Dict exposing (..)
-import List
-import Maybe
-import Time exposing (Time)
-import Date
-
-import Model.Payment exposing (Payments, totalPayments)
-import Model.User exposing (Users, UserId, userIdDecoder)
-import Model.Income exposing (..)
-
-import Utils.Dict exposing (mapValues)
-
-type alias Payers = Dict UserId Payer
-
-type alias Payer =
- { preIncomePaymentSum : Int
- , postIncomePaymentSum : Int
- , incomes : List Income
- }
-
-type alias PostPaymentPayer =
- { preIncomePaymentSum : Int
- , cumulativeIncome : Int
- , ratio : Float
- }
-
-type alias ExceedingPayer =
- { userId : UserId
- , amount : Int
- }
-
-getOrderedExceedingPayers : Time -> Users -> Incomes -> Payments -> List ExceedingPayer
-getOrderedExceedingPayers currentTime users incomes payments =
- let payers = getPayers currentTime users incomes payments
- exceedingPayersOnPreIncome =
- payers
- |> mapValues .preIncomePaymentSum
- |> Dict.toList
- |> exceedingPayersFromAmounts
- mbSince = useIncomesFrom users incomes payments
- in case mbSince of
- Just since ->
- let postPaymentPayers = mapValues (getPostPaymentPayer currentTime since) payers
- mbMaxRatio =
- postPaymentPayers
- |> Dict.toList
- |> List.map (.ratio << Tuple.second)
- |> List.maximum
- in case mbMaxRatio of
- Just maxRatio ->
- postPaymentPayers
- |> mapValues (getFinalDiff maxRatio)
- |> Dict.toList
- |> exceedingPayersFromAmounts
- Nothing ->
- exceedingPayersOnPreIncome
- _ ->
- exceedingPayersOnPreIncome
-
-useIncomesFrom : Users -> Incomes -> Payments -> Maybe Time
-useIncomesFrom users incomes payments =
- let firstPaymentTime =
- payments
- |> List.map (Date.toTime << .date)
- |> List.sort
- |> List.head
- mbIncomeTime = incomeDefinedForAll (Dict.keys users) incomes
- in case (firstPaymentTime, mbIncomeTime) of
- (Just paymentTime, Just incomeTime) ->
- Just (max paymentTime incomeTime)
- _ ->
- Nothing
-
-getPayers : Time -> Users -> Incomes -> Payments -> Payers
-getPayers currentTime users incomes payments =
- let userIds = Dict.keys users
- incomesDefined = incomeDefinedForAll userIds incomes
- in userIds
- |> List.map (\userId ->
- ( userId
- , { preIncomePaymentSum =
- totalPayments
- (\p -> (Date.toTime p.date) < (Maybe.withDefault currentTime incomesDefined))
- userId
- payments
- , postIncomePaymentSum =
- totalPayments
- (\p ->
- case incomesDefined of
- Nothing -> False
- Just t -> (Date.toTime p.date) >= t
- )
- userId
- payments
- , incomes = List.filter ((==) userId << .userId) (Dict.values incomes)
- }
- )
- )
- |> Dict.fromList
-
-exceedingPayersFromAmounts : List (UserId, Int) -> List ExceedingPayer
-exceedingPayersFromAmounts userAmounts =
- let mbMinAmount = List.minimum << List.map Tuple.second <| userAmounts
- in case mbMinAmount of
- Nothing ->
- []
- Just minAmount ->
- userAmounts
- |> List.map (\userAmount ->
- { userId = Tuple.first userAmount
- , amount = Tuple.second userAmount - minAmount
- }
- )
- |> List.filter (\payer -> payer.amount > 0)
-
-getPostPaymentPayer : Time -> Time -> Payer -> PostPaymentPayer
-getPostPaymentPayer currentTime since payer =
- let cumulativeIncome = cumulativeIncomesSince currentTime since payer.incomes
- in { preIncomePaymentSum = payer.preIncomePaymentSum
- , cumulativeIncome = cumulativeIncome
- , ratio = toFloat payer.postIncomePaymentSum / toFloat cumulativeIncome
- }
-
-getFinalDiff : Float -> PostPaymentPayer -> Int
-getFinalDiff maxRatio payer =
- let postIncomeDiff =
- -1 * (maxRatio - payer.ratio) * toFloat payer.cumulativeIncome
- |> truncate
- in postIncomeDiff + payer.preIncomePaymentSum
diff --git a/src/client/Model/Payment.elm b/src/client/Model/Payment.elm
deleted file mode 100644
index 204f9f5..0000000
--- a/src/client/Model/Payment.elm
+++ /dev/null
@@ -1,117 +0,0 @@
-module Model.Payment exposing
- ( perPage
- , Payments
- , Payment
- , PaymentId
- , paymentsDecoder
- , paymentIdDecoder
- , find
- , edit
- , delete
- , totalPayments
- , punctual
- , monthly
- , groupAndSortByMonth
- , search
- )
-
-import Date exposing (..)
-import Date.Extra.Core exposing (monthToInt, intToMonth)
-import Json.Decode as Decode exposing (Decoder)
-import Json.Decode.Extra as Decode
-import List
-import List.Extra as List
-
-import Form.Validate as Validate exposing (Validation)
-import Model.Date exposing (dateDecoder)
-import Model.Frequency as Frequency exposing (Frequency(..))
-import Model.User exposing (UserId, userIdDecoder)
-import Utils.List as List
-import Utils.Search as Search
-
-perPage : Int
-perPage = 7
-
-type alias Payments = List Payment
-
-type alias Payment =
- { id : PaymentId
- , name : String
- , cost : Int
- , date : Date
- , userId : UserId
- , frequency : Frequency
- }
-
-type alias PaymentId = Int
-
-paymentsDecoder : Decoder Payments
-paymentsDecoder = Decode.list paymentDecoder
-
-paymentDecoder : Decoder Payment
-paymentDecoder =
- Decode.map6 Payment
- (Decode.field "id" paymentIdDecoder)
- (Decode.field "name" Decode.string)
- (Decode.field "cost" Decode.int)
- (Decode.field "date" dateDecoder)
- (Decode.field "userId" userIdDecoder)
- (Decode.field "frequency" Frequency.decoder)
-
-paymentIdDecoder : Decoder PaymentId
-paymentIdDecoder = Decode.int
-
-find : PaymentId -> Payments -> Maybe Payment
-find paymentId payments =
- payments
- |> List.find (\p -> p.id == paymentId)
-
-edit : Payment -> Payments -> Payments
-edit payment payments = payment :: delete payment.id payments
-
-delete : PaymentId -> Payments -> Payments
-delete paymentId = List.filter (((/=) paymentId) << .id)
-
-totalPayments : (Payment -> Bool) -> UserId -> Payments -> Int
-totalPayments paymentFilter userId payments =
- payments
- |> List.filter (\payment ->
- paymentFilter payment
- && payment.userId == userId
- )
- |> List.map .cost
- |> List.sum
-
-punctual : Payments -> Payments
-punctual = List.filter ((==) Punctual << .frequency)
-
-monthly : Payments -> Payments
-monthly = List.filter ((==) Monthly << .frequency)
-
-groupAndSortByMonth : Payments -> List ((Month, Int), Payments)
-groupAndSortByMonth payments =
- payments
- |> List.groupBy (\payment -> (Date.year payment.date, monthToInt << Date.month <| payment.date))
- |> List.sortBy Tuple.first
- |> List.map (\((year, month), payments) -> ((intToMonth month, year), payments))
-
-search : String -> Frequency -> Payments -> Payments
-search name frequency payments =
- payments
- |> List.filter ((==) frequency << .frequency)
- |> paymentSort frequency
- |> List.filter (searchSuccess name)
-
-paymentSort : Frequency -> Payments -> Payments
-paymentSort frequency =
- case frequency of
- Punctual -> List.reverse << List.sortBy (Date.toTime << .date)
- Monthly -> List.sortBy (String.toLower << .name)
-
-searchSuccess : String -> Payment -> Bool
-searchSuccess search { name, cost } =
- let searchSuccessWord word =
- ( String.contains (Search.format word) (Search.format name)
- || String.contains word (toString cost)
- )
- in List.all searchSuccessWord (String.words search)
diff --git a/src/client/Model/PaymentCategory.elm b/src/client/Model/PaymentCategory.elm
deleted file mode 100644
index a4fceb1..0000000
--- a/src/client/Model/PaymentCategory.elm
+++ /dev/null
@@ -1,61 +0,0 @@
-module Model.PaymentCategory exposing
- ( PaymentCategories
- , paymentCategoriesDecoder
- , search
- , groupPaymentsByCategory
- , isCategoryUnused
- , save
- )
-
-import Dict exposing (Dict)
-import Json.Decode as Decode exposing (Decoder)
-import List.Extra as List
-import Maybe.Extra as Maybe
-
-import Model.Category exposing (CategoryId, categoryIdDecoder)
-import Model.Payment exposing (Payments)
-import Utils.Json as Json
-import Utils.List as List
-import Utils.Search as Search
-
-type alias PaymentCategories = List PaymentCategory
-
-type alias PaymentCategory =
- { name : String
- , category : CategoryId
- }
-
-paymentCategoriesDecoder : Decoder PaymentCategories
-paymentCategoriesDecoder =
- Decode.list <| Decode.map2 PaymentCategory
- (Decode.field "name" Decode.string)
- (Decode.field "category" categoryIdDecoder)
-
-groupPaymentsByCategory : PaymentCategories -> Payments -> List (CategoryId, Payments)
-groupPaymentsByCategory paymentCategories payments =
- payments
- |> List.groupBy (\payment ->
- search payment.name paymentCategories
- |> Maybe.withDefault -1
- )
- |> List.filterMap (\(category, payments) ->
- case category of
- -1 -> Nothing
- _ -> Just (category, payments)
- )
-
-search : String -> PaymentCategories -> Maybe CategoryId
-search paymentName paymentCategories =
- paymentCategories
- |> List.find (\pc -> Search.format pc.name == Search.format paymentName)
- |> Maybe.map .category
-
-isCategoryUnused : CategoryId -> PaymentCategories -> Bool
-isCategoryUnused category paymentCategories =
- paymentCategories
- |> List.find ((==) category << .category)
- |> Maybe.isNothing
-
-save : String -> CategoryId -> PaymentCategories -> PaymentCategories
-save name category paymentCategories =
- { name = name, category = category } :: List.filter (\pc -> not <| Search.format pc.name == Search.format name) paymentCategories
diff --git a/src/client/Model/Size.elm b/src/client/Model/Size.elm
deleted file mode 100644
index f40fb01..0000000
--- a/src/client/Model/Size.elm
+++ /dev/null
@@ -1,17 +0,0 @@
-module Model.Size exposing
- ( Size
- , sizeDecoder
- )
-
-import Json.Decode as Decode exposing (Decoder)
-
-type alias Size =
- { width: Int
- , height: Int
- }
-
-sizeDecoder : Decoder Size
-sizeDecoder =
- Decode.map2 Size
- (Decode.field "width" Decode.int)
- (Decode.field "height" Decode.int)
diff --git a/src/client/Model/Translations.elm b/src/client/Model/Translations.elm
deleted file mode 100644
index 9b314e1..0000000
--- a/src/client/Model/Translations.elm
+++ /dev/null
@@ -1,68 +0,0 @@
-module Model.Translations exposing
- ( translationsDecoder
- , Translations
- , Translation
- , getMessage
- , getParamMessage
- )
-
-import Maybe exposing (withDefault)
-import Json.Decode as Decode exposing (Decoder)
-import String
-
-type alias Translations = List Translation
-
-translationsDecoder : Decoder Translations
-translationsDecoder = Decode.list translationDecoder
-
-type alias Translation =
- { key : String
- , message : List MessagePart
- }
-
-getTranslation : String -> Translations -> Maybe (List MessagePart)
-getTranslation key translations =
- translations
- |> List.filter (\translation -> String.toLower translation.key == String.toLower key)
- |> List.head
- |> Maybe.map .message
-
-translationDecoder : Decoder Translation
-translationDecoder =
- Decode.map2 Translation
- (Decode.field "key" Decode.string)
- (Decode.field "message" (Decode.list partDecoder))
-
-type MessagePart =
- Order Int
- | Str String
-
-partDecoder : Decoder MessagePart
-partDecoder = (Decode.field "tag" Decode.string) |> Decode.andThen partDecoderWithTag
-
-partDecoderWithTag : String -> Decoder MessagePart
-partDecoderWithTag tag =
- case tag of
- "Order" -> Decode.map Order (Decode.field "contents" Decode.int)
- _ -> Decode.map Str (Decode.field "contents" Decode.string)
-
------
-
-getMessage : Translations -> String -> String
-getMessage = getParamMessage []
-
-getParamMessage : List String -> Translations -> String -> String
-getParamMessage values translations key =
- getTranslation key translations
- |> Maybe.map (\parts -> String.concat (List.map (replacePart values) parts))
- |> withDefault key
-
-replacePart : List String -> MessagePart -> String
-replacePart values part =
- case part of
- Str str -> str
- Order n ->
- values
- |> List.drop (n - 1)
- |> List.head
- |> withDefault ("{" ++ (toString n) ++ "}")
diff --git a/src/client/Model/User.elm b/src/client/Model/User.elm
deleted file mode 100644
index f6e8147..0000000
--- a/src/client/Model/User.elm
+++ /dev/null
@@ -1,44 +0,0 @@
-module Model.User exposing
- ( Users
- , usersDecoder
- , User
- , userDecoder
- , UserId
- , userIdDecoder
- , getUserName
- )
-
-import Json.Decode as Decode exposing (Decoder)
-import Dict exposing (Dict)
-
-type alias Users = Dict UserId User
-
-type alias UserId = Int
-
-type alias User =
- { name : String
- , email : String
- }
-
-usersDecoder : Decoder Users
-usersDecoder = Decode.map Dict.fromList (Decode.list userWithIdDecoder)
-
-userWithIdDecoder : Decode.Decoder (UserId, User)
-userWithIdDecoder =
- Decode.map2 (,)
- (Decode.field "id" userIdDecoder)
- userDecoder
-
-userIdDecoder : Decoder UserId
-userIdDecoder = Decode.int
-
-userDecoder : Decoder User
-userDecoder =
- Decode.map2 User
- (Decode.field "name" Decode.string)
- (Decode.field "email" Decode.string)
-
-getUserName : Users -> UserId -> Maybe String
-getUserName users userId =
- Dict.get userId users
- |> Maybe.map .name
diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm
deleted file mode 100644
index 61d42a7..0000000
--- a/src/client/Model/View.elm
+++ /dev/null
@@ -1,12 +0,0 @@
-module Model.View exposing
- ( View(..)
- )
-
-import Model.Payment exposing (Payments)
-
-import SignIn.Model as SignInModel
-import LoggedIn.Model as LoggedInModel
-
-type View =
- SignInView SignInModel.Model
- | LoggedInView LoggedInModel.Model
diff --git a/src/client/Msg.elm b/src/client/Msg.elm
deleted file mode 100644
index 5970747..0000000
--- a/src/client/Msg.elm
+++ /dev/null
@@ -1,49 +0,0 @@
-module Msg exposing
- ( Msg(..)
- )
-
-import Date exposing (Date)
-import Time exposing (Time)
-
-import Page exposing (Page)
-
-import Model.Init exposing (Init)
-import Model.Payment exposing (PaymentId)
-import Model.Frequency exposing (Frequency)
-import Model.Income exposing (IncomeId)
-import Model.Category exposing (CategoryId)
-
-import Dialog
-import Dialog.Model as DialogModel
-import Dialog.Msg as DialogMsg
-
-import Tooltip
-
-import SignIn.Msg as SignInMsg
-import LoggedIn.Msg as LoggedInMsg
-
-type Msg =
- NoOp
- | UpdatePage Page
- | SignIn String
- | UpdateTime Time
- | GoLoggedInView Init
- | UpdateSignIn SignInMsg.Msg
- | UpdateLoggedIn LoggedInMsg.Msg
- | GoSignInView
- | SignOut
- | Error String
- | Dialog (Dialog.Msg DialogModel.Model DialogMsg.Msg Msg)
- | Tooltip Tooltip.Msg
-
- | CreatePayment String Int Date CategoryId Frequency
- | EditPayment PaymentId String Int Date CategoryId Frequency
- | DeletePayment PaymentId
-
- | CreateIncome Int Date
- | EditIncome IncomeId Int Date
- | DeleteIncome IncomeId
-
- | CreateCategory String String
- | EditCategory CategoryId String String
- | DeleteCategory CategoryId
diff --git a/src/client/Page.elm b/src/client/Page.elm
deleted file mode 100644
index 39232e0..0000000
--- a/src/client/Page.elm
+++ /dev/null
@@ -1,43 +0,0 @@
-module Page exposing
- ( Page(..)
- , toHash
- , fromLocation
- )
-
-import Navigation exposing (Location)
-import UrlParser exposing (Parser, (</>), s)
-import String
-
-type Page =
- Home
- | Income
- | Categories
- | Statistics
- | NotFound
-
-toHash : Page -> String
-toHash page =
- case page of
- Home -> "#"
- Income -> "#income"
- Categories -> "#categories"
- Statistics -> "#statistics"
- NotFound -> "#notFound"
-
-fromLocation : Location -> Page
-fromLocation location =
- if location.hash == ""
- then
- Home
- else
- case UrlParser.parseHash pageParser location of
- Just page -> page
- Nothing -> NotFound
-
-pageParser : Parser (Page -> a) a
-pageParser =
- UrlParser.oneOf
- [ UrlParser.map Income (s "income")
- , UrlParser.map Categories (s "categories")
- , UrlParser.map Statistics (s "statistics")
- ]
diff --git a/src/client/Server.elm b/src/client/Server.elm
deleted file mode 100644
index c44b777..0000000
--- a/src/client/Server.elm
+++ /dev/null
@@ -1,115 +0,0 @@
-module Server exposing
- ( signIn
- , createPayment
- , editPayment
- , deletePayment
- , createIncome
- , editIncome
- , deleteIncome
- , createCategory
- , editCategory
- , deleteCategory
- , signOut
- )
-
-import Task as Task exposing (Task)
-import Http exposing (Error)
-import Date
-import Json.Decode as Decode
-import Json.Encode as Encode
-import Date exposing (Date)
-
-import Date.Extra.Format as DateFormat
-
-import Utils.Http as HttpUtils
-
-import Model.Payment exposing (..)
-import Model.Frequency exposing (Frequency)
-import Model.Income exposing (incomeIdDecoder, IncomeId)
-import Model.Category exposing (categoryIdDecoder, CategoryId)
-import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
-import Model.Init exposing (Init)
-
-signIn : String -> (Result Error String -> msg) -> Cmd msg
-signIn email = HttpUtils.request "POST" ("/signIn?email=" ++ email) Http.expectString
-
-createPayment : String -> Int -> Date -> CategoryId -> Frequency -> (Result Error PaymentId -> msg) -> Cmd msg
-createPayment name cost date categoryId frequency handleResult =
- let json =
- Encode.object
- [ ("name", Encode.string name)
- , ("cost", Encode.int cost)
- , ("date", Encode.string (DateFormat.isoDateString date))
- , ("category", Encode.int categoryId)
- , ("frequency", Encode.string (toString frequency))
- ]
- expect = Http.expectJson (Decode.field "id" paymentIdDecoder)
- in HttpUtils.jsonRequest "POST" "/payment" expect handleResult json
-
-editPayment : PaymentId -> String -> Int -> Date -> CategoryId -> Frequency -> (Result Error String -> msg) -> Cmd msg
-editPayment paymentId name cost date categoryId frequency handleResult =
- let json =
- Encode.object
- [ ("id", Encode.int paymentId)
- , ("name", Encode.string name)
- , ("cost", Encode.int cost)
- , ("date", Encode.string (DateFormat.isoDateString date))
- , ("category", Encode.int categoryId)
- , ("frequency", Encode.string (toString frequency))
- ]
- in HttpUtils.jsonRequest "PUT" "/payment" Http.expectString handleResult json
-
-deletePayment : PaymentId -> (Result Error String -> msg) -> Cmd msg
-deletePayment paymentId =
- HttpUtils.request "DELETE" ("/payment?id=" ++ (toString paymentId)) Http.expectString
-
-createIncome : Int -> Date -> (Result Error IncomeId -> msg) -> Cmd msg
-createIncome amount date handleResult =
- let json =
- Encode.object
- [ ("amount", Encode.int amount)
- , ("date", Encode.string (DateFormat.isoDateString date))
- ]
- expect = Http.expectJson (Decode.field "id" incomeIdDecoder)
- in HttpUtils.jsonRequest "POST" "/income" expect handleResult json
-
-editIncome : IncomeId -> Int -> Date -> (Result Error String -> msg) -> Cmd msg
-editIncome incomeId amount date handleResult =
- let json =
- Encode.object
- [ ("id", Encode.int incomeId)
- , ("amount", Encode.int amount)
- , ("date", Encode.string (DateFormat.isoDateString date))
- ]
- in HttpUtils.jsonRequest "PUT" "/income" Http.expectString handleResult json
-
-deleteIncome : IncomeId -> (Result Error String -> msg) -> Cmd msg
-deleteIncome incomeId =
- HttpUtils.request "DELETE" ("/income?id=" ++ (toString incomeId)) Http.expectString
-
-createCategory : String -> String -> (Result Error CategoryId -> msg) -> Cmd msg
-createCategory name color handleResult =
- let json =
- Encode.object
- [ ("name", Encode.string name)
- , ("color", Encode.string color)
- ]
- expect = Http.expectJson (Decode.field "id" categoryIdDecoder)
- in HttpUtils.jsonRequest "POST" "/category" expect handleResult json
-
-editCategory : CategoryId -> String -> String -> (Result Error String -> msg) -> Cmd msg
-editCategory categoryId name color handleResult =
- let json =
- Encode.object
- [ ("id", Encode.int categoryId)
- , ("name", Encode.string name)
- , ("color", Encode.string color)
- ]
- in HttpUtils.jsonRequest "PUT" "/category" Http.expectString handleResult json
-
-deleteCategory : CategoryId -> (Result Error String -> msg) -> Cmd msg
-deleteCategory categoryId =
- HttpUtils.request "DELETE" ("/category?id=" ++ (toString categoryId)) Http.expectString
-
-signOut : (Result Error String -> msg) -> Cmd msg
-signOut = HttpUtils.request "POST" "/signOut" Http.expectString
diff --git a/src/client/SignIn/Model.elm b/src/client/SignIn/Model.elm
deleted file mode 100644
index 19d4305..0000000
--- a/src/client/SignIn/Model.elm
+++ /dev/null
@@ -1,17 +0,0 @@
-module SignIn.Model exposing
- ( Model
- , init
- )
-
-type alias Model =
- { login : String
- , waitingServer : Bool
- , result : Maybe (Result String String)
- }
-
-init : Maybe String -> Model
-init mbSignInError =
- { login = ""
- , waitingServer = False
- , result = Maybe.map Err mbSignInError
- }
diff --git a/src/client/SignIn/Msg.elm b/src/client/SignIn/Msg.elm
deleted file mode 100644
index f753ebd..0000000
--- a/src/client/SignIn/Msg.elm
+++ /dev/null
@@ -1,9 +0,0 @@
-module SignIn.Msg exposing
- ( Msg(..)
- )
-
-type Msg =
- UpdateLogin String
- | WaitingServer
- | ValidLogin
- | ErrorLogin String
diff --git a/src/client/SignIn/Update.elm b/src/client/SignIn/Update.elm
deleted file mode 100644
index 98de777..0000000
--- a/src/client/SignIn/Update.elm
+++ /dev/null
@@ -1,31 +0,0 @@
-module SignIn.Update exposing
- ( update
- )
-
-import SignIn.Model exposing (..)
-import SignIn.Msg exposing (..)
-
-import Model.Translations exposing (getMessage, Translations)
-
-update : Translations -> Msg -> Model -> Model
-update translations msg signInView =
- case msg of
- UpdateLogin login ->
- { signInView |
- login = login
- }
- WaitingServer ->
- { signInView
- | waitingServer = True
- }
- ValidLogin ->
- { signInView
- | login = ""
- , result = Just (Ok (getMessage translations "SignInEmailSent"))
- , waitingServer = False
- }
- ErrorLogin message ->
- { signInView
- | result = Just (Err message)
- , waitingServer = False
- }
diff --git a/src/client/SignIn/View.elm b/src/client/SignIn/View.elm
deleted file mode 100644
index 88f74b0..0000000
--- a/src/client/SignIn/View.elm
+++ /dev/null
@@ -1,63 +0,0 @@
-module SignIn.View exposing
- ( view
- )
-
-import Json.Decode as Decode
-
-import FontAwesome
-import View.Color as Color
-
-import Html as H exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import SignIn.Msg as SignInMsg
-import SignIn.Model as SignInModel
-
-import Update exposing (..)
-
-import Model exposing (Model)
-import Msg exposing (..)
-import Model.Translations exposing (getMessage)
-
-import View.Events exposing (onSubmitPrevDefault)
-
-view : Model -> SignInModel.Model -> Html Msg
-view model signInModel =
- div
- [ class "signIn" ]
- [ H.form
- [ onSubmitPrevDefault (SignIn signInModel.login) ]
- [ input
- [ value signInModel.login
- , on "input" (targetValue |> (Decode.map <| (UpdateSignIn << SignInMsg.UpdateLogin)))
- , name "email"
- ]
- []
- , button
- []
- [ if signInModel.waitingServer
- then FontAwesome.spinner Color.white 20
- else text (getMessage model.translations "SignIn")
- ]
- ]
- , div
- [ class "result" ]
- [ signInResult model signInModel ]
- ]
-
-signInResult : Model -> SignInModel.Model -> Html Msg
-signInResult model signInModel =
- case signInModel.result of
- Just result ->
- case result of
- Ok login ->
- div
- [ class "success" ]
- [ text (getMessage model.translations "SignInEmailSent") ]
- Err error ->
- div
- [ class "error" ]
- [ text (getMessage model.translations error) ]
- Nothing ->
- text ""
diff --git a/src/client/Tooltip.elm b/src/client/Tooltip.elm
deleted file mode 100644
index 4f70cda..0000000
--- a/src/client/Tooltip.elm
+++ /dev/null
@@ -1,113 +0,0 @@
-module Tooltip exposing
- ( Msg(..)
- , Model
- , init
- , subscription
- , update
- , view
- , show
- )
-
-import Platform.Cmd
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-import Html.Events exposing (..)
-
-import Mouse exposing (Position)
-import Window exposing (Size)
-
-type Msg =
- UpdateMousePosition Position
- | UpdateWindowSize Size
- | ShowMessage String
- | HideMessage
-
-type alias Model =
- { mousePosition : Maybe Position
- , windowSize : Size
- , message : Maybe String
- }
-
-init : Int -> Int -> Model
-init width height =
- { mousePosition = Nothing
- , windowSize =
- { width = width
- , height = height
- }
- , message = Nothing
- }
-
-subscription : Sub Msg
-subscription =
- Sub.batch
- [ Mouse.moves UpdateMousePosition
- , Window.resizes UpdateWindowSize
- ]
-
-update : Msg -> Model -> (Model, Cmd Msg)
-update msg model =
- case msg of
- UpdateMousePosition position ->
- ( { model | mousePosition = Just position }
- , Cmd.none
- )
-
- UpdateWindowSize size ->
- ( { model | windowSize = size }
- , Cmd.none
- )
-
- ShowMessage message ->
- ( { model | message = Just message }
- , Cmd.none
- )
-
- HideMessage ->
- ( { model | message = Nothing }
- , Cmd.none
- )
-
-view : Model -> Html Msg
-view { mousePosition, windowSize, message } =
- case (mousePosition, message) of
- (Just pos, Just msg) ->
- div
- [ class "tooltip"
- , style
- [ ("position", "absolute")
- , horizontalPosition windowSize pos
- , ("top", px <| pos.y + 15)
- ]
- ]
- [ text msg ]
- _ ->
- text ""
-
-horizontalPosition : Size -> Position -> (String, String)
-horizontalPosition size position =
- if isLeft size position
- then ("left", px <| position.x + 5)
- else ("right", px <| size.width - position.x)
-
-verticalPosition : Size -> Position -> (String, String)
-verticalPosition size position =
- if isTop size position
- then ("top", px <| position.y + 20)
- else ("bottom", px <| size.height - position.y + 15)
-
-px : Int -> String
-px n = (toString n) ++ "px"
-
-isLeft : Size -> Position -> Bool
-isLeft { width } { x } = x < width // 2
-
-isTop : Size -> Position -> Bool
-isTop { height } { y } = y < height // 2
-
-show : (Msg -> msg) -> String -> List (Attribute msg)
-show mapMsg message =
- [ onMouseEnter <| mapMsg <| ShowMessage message
- , onMouseLeave <| mapMsg <| HideMessage
- ]
diff --git a/src/client/Update.elm b/src/client/Update.elm
deleted file mode 100644
index 4284b65..0000000
--- a/src/client/Update.elm
+++ /dev/null
@@ -1,182 +0,0 @@
-module Update exposing
- ( update
- )
-
-import Navigation exposing (Location)
-import Platform.Cmd exposing (Cmd)
-import Task
-
-import Dialog
-import Dialog.Update as DialogUpdate
-import LoggedIn.Model as LoggedIn
-import LoggedIn.Msg as LoggedIn
-import LoggedIn.Stat.Msg as Stat
-import LoggedIn.Update as LoggedIn
-import Model exposing (Model)
-import Model.Translations exposing (getMessage)
-import Model.View as V
-import Msg exposing (..)
-import Page exposing (Page(..))
-import Server
-import SignIn.Model as SignInModel
-import SignIn.Msg as SignInMsg
-import SignIn.Update as SignInUpdate
-import Tooltip
-import Utils.Cmd exposing ((:>))
-import Utils.Http exposing (errorKey)
-
-update : Msg -> Model -> (Model, Cmd Msg)
-update msg model =
- case msg of
-
- NoOp ->
- (model, Cmd.none)
-
- UpdatePage page ->
- ( { model | page = page }
- , if page == Statistics
- then
- let msg = UpdateLoggedIn <| LoggedIn.StatMsg <| Stat.UpdateChart
- in Task.perform (\_ -> msg) (Task.succeed ())
- else
- Cmd.none
- )
-
- SignIn email ->
- ( applySignIn model (SignInMsg.WaitingServer)
- , Server.signIn email (\result -> case result of
- Ok _ -> UpdateSignIn SignInMsg.ValidLogin
- Err error -> UpdateSignIn (SignInMsg.ErrorLogin (errorKey error))
- )
- )
-
- GoLoggedInView init ->
- ( { model | view = V.LoggedInView (LoggedIn.init model.currentTime init) }
- , Cmd.none
- )
-
- UpdateTime time ->
- ({ model | currentTime = time }, Cmd.none)
-
- GoSignInView ->
- ({ model | view = V.SignInView (SignInModel.init Nothing) }, Cmd.none)
-
- UpdateSignIn signInMsg ->
- (applySignIn model signInMsg, Cmd.none)
-
- UpdateLoggedIn loggedInMsg ->
- applyLoggedIn model loggedInMsg
-
- SignOut ->
- ( model
- , Server.signOut (\result -> case result of
- Ok _ -> GoSignInView
- Err _ -> Error "SignOutError"
- )
- )
-
- Error error ->
- ({ model | errors = model.errors ++ [ error ] }, Cmd.none)
-
- Dialog dialogMsg ->
- Dialog.update DialogUpdate.update dialogMsg model.dialog.model model.dialog
- |> Tuple.mapFirst (\dialog -> { model | dialog = dialog })
- :> update (Tooltip Tooltip.HideMessage)
-
- Tooltip tooltipMsg ->
- let (newTooltip, command) = Tooltip.update tooltipMsg model.tooltip
- in ( { model | tooltip = newTooltip }
- , Cmd.map Tooltip command
- )
-
- CreatePayment name cost date category frequency ->
- ( model
- , Server.createPayment name cost date category frequency (\result -> case result of
- Ok paymentId -> UpdateLoggedIn <| LoggedIn.ValidateCreatePayment paymentId name cost date category frequency
- Err _ -> Error "CreatePaymentError"
- )
- )
-
- EditPayment paymentId name cost date category frequency ->
- ( model
- , Server.editPayment paymentId name cost date category frequency (\result -> case result of
- Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditPayment paymentId name cost date category frequency
- Err _ -> Error "EditPaymentError"
- )
- )
-
- DeletePayment paymentId ->
- ( model
- , Server.deletePayment paymentId (\result -> case result of
- Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeletePayment paymentId
- Err _ -> Error "DeletePaymentError"
- )
- )
-
- CreateIncome amount date ->
- ( model
- , Server.createIncome amount date (\result -> case result of
- Ok incomeId -> UpdateLoggedIn <| LoggedIn.ValidateCreateIncome incomeId amount date
- Err _ -> Error "CreateIncomeError"
- )
- )
-
- EditIncome incomeId amount date ->
- ( model
- , Server.editIncome incomeId amount date (\result -> case result of
- Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditIncome incomeId amount date
- Err _ -> Error "EditIncomeError"
- )
- )
-
- DeleteIncome incomeId ->
- ( model
- , Server.deleteIncome incomeId (\result -> case result of
- Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteIncome incomeId
- Err _ -> Error "DeleteIncomeError"
- )
- )
-
- CreateCategory name color ->
- ( model
- , Server.createCategory name color (\result -> case result of
- Ok categoryId -> UpdateLoggedIn <| LoggedIn.ValidateCreateCategory categoryId name color
- Err _ -> Error "CreateCategoryError"
- )
- )
-
- EditCategory categoryId name color ->
- ( model
- , Server.editCategory categoryId name color (\result -> case result of
- Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateEditCategory categoryId name color
- Err _ -> Error "EditCategoryError"
- )
- )
-
- DeleteCategory categoryId ->
- ( model
- , Server.deleteCategory categoryId (\result -> case result of
- Ok _ -> UpdateLoggedIn <| LoggedIn.ValidateDeleteCategory categoryId
- Err _ -> Error "DeleteCategoryError"
- )
- )
-
-
-applySignIn : Model -> SignInMsg.Msg -> Model
-applySignIn model signInMsg =
- case model.view of
- V.SignInView signInView ->
- { model | view = V.SignInView (SignInUpdate.update model.translations signInMsg signInView) }
- _ ->
- model
-
-applyLoggedIn : Model -> LoggedIn.Msg -> (Model, Cmd Msg)
-applyLoggedIn model loggedInMsg =
- case model.view of
- V.LoggedInView loggedInView ->
- let (view, cmd) = LoggedIn.update model loggedInMsg loggedInView
- in ( { model | view = V.LoggedInView view }
- , Cmd.map UpdateLoggedIn cmd
- )
- _ ->
- (model, Cmd.none)
diff --git a/src/client/Utils/Cmd.elm b/src/client/Utils/Cmd.elm
deleted file mode 100644
index 5f41cbe..0000000
--- a/src/client/Utils/Cmd.elm
+++ /dev/null
@@ -1,16 +0,0 @@
-module Utils.Cmd exposing
- ( pipeUpdate
- , (:>)
- )
-
-import Platform.Cmd as Cmd
-
-pipeUpdate : (model, Cmd msg) -> (model -> (model, Cmd msg)) -> (model, Cmd msg)
-pipeUpdate (model, cmd) f =
- let (newModel, newCmd) = f model
- in (newModel, Cmd.batch [ cmd, newCmd ])
-
-(:>) : (m, Cmd a) -> (m -> (m, Cmd a)) -> (m, Cmd a)
-(:>) = pipeUpdate
-
-infixl 0 :>
diff --git a/src/client/Utils/Dict.elm b/src/client/Utils/Dict.elm
deleted file mode 100644
index 7d708e2..0000000
--- a/src/client/Utils/Dict.elm
+++ /dev/null
@@ -1,11 +0,0 @@
-module Utils.Dict exposing
- ( mapValues
- )
-
-import Dict as Dict exposing (..)
-
-mapValues : (a -> b) -> Dict comparable a -> Dict comparable b
-mapValues f = Dict.fromList << List.map (onSecond f) << Dict.toList
-
-onSecond : (a -> b) -> (comparable, a) -> (comparable, b)
-onSecond f tuple = case tuple of (x, y) -> (x, f y)
diff --git a/src/client/Utils/Either.elm b/src/client/Utils/Either.elm
deleted file mode 100644
index 275fc8c..0000000
--- a/src/client/Utils/Either.elm
+++ /dev/null
@@ -1,9 +0,0 @@
-module Utils.Either exposing
- ( toMaybeError
- )
-
-toMaybeError : Result a b -> Maybe a
-toMaybeError result =
- case result of
- Ok _ -> Nothing
- Err x -> Just x
diff --git a/src/client/Utils/Form.elm b/src/client/Utils/Form.elm
deleted file mode 100644
index 6793222..0000000
--- a/src/client/Utils/Form.elm
+++ /dev/null
@@ -1,11 +0,0 @@
-module Utils.Form exposing
- ( fieldAsText
- )
-
-import Form exposing (Form)
-
-fieldAsText : Form a b -> String -> String
-fieldAsText form field =
- Form.getFieldAsString field form
- |> .value
- |> Maybe.withDefault ""
diff --git a/src/client/Utils/Http.elm b/src/client/Utils/Http.elm
deleted file mode 100644
index dd3870a..0000000
--- a/src/client/Utils/Http.elm
+++ /dev/null
@@ -1,39 +0,0 @@
-module Utils.Http exposing
- ( jsonRequest
- , request
- , errorKey
- )
-
-import Http exposing (..)
-import Task exposing (..)
-import Json.Decode as Decode exposing (Decoder, Value)
-import Json.Encode as Encode
-
-jsonRequest : String -> String -> Expect a -> (Result Error a -> msg) -> Encode.Value -> Cmd msg
-jsonRequest method url expect handleResult value =
- requestWithBody method url (jsonBody value) expect handleResult
-
-request : String -> String -> Expect a -> (Result Error a -> msg) -> Cmd msg
-request method url = requestWithBody method url emptyBody
-
-requestWithBody : String -> String -> Body -> Expect a -> (Result Error a -> msg) -> Cmd msg
-requestWithBody method url body expect handleResult =
- let req = Http.request
- { method = method
- , headers = []
- , url = url
- , body = body
- , expect = expect
- , timeout = Nothing
- , withCredentials = False
- }
- in send handleResult req
-
-errorKey : Error -> String
-errorKey error =
- case error of
- BadUrl _ -> "BadUrl"
- Timeout -> "Timeout"
- NetworkError -> "NetworkError"
- BadPayload _ _ -> "BadPayload"
- BadStatus response -> response.body
diff --git a/src/client/Utils/Json.elm b/src/client/Utils/Json.elm
deleted file mode 100644
index 29e815b..0000000
--- a/src/client/Utils/Json.elm
+++ /dev/null
@@ -1,12 +0,0 @@
-module Utils.Json exposing
- ( dictDecoder
- )
-
-import Json.Decode as Decode exposing (Decoder)
-import Dict exposing (Dict)
-
-dictDecoder : Decoder comparable -> Decoder a -> Decoder (Dict comparable a)
-dictDecoder keyDecoder valueDecoder =
- Decode.map2 (,) keyDecoder valueDecoder
- |> Decode.list
- |> Decode.map Dict.fromList
diff --git a/src/client/Utils/List.elm b/src/client/Utils/List.elm
deleted file mode 100644
index 8e26e85..0000000
--- a/src/client/Utils/List.elm
+++ /dev/null
@@ -1,36 +0,0 @@
-module Utils.List exposing
- ( groupBy
- , mean
- , links
- )
-
-import Dict
-import Maybe.Extra as Maybe
-
-groupBy : (a -> comparable) -> List a -> List (comparable, List a)
-groupBy f xs =
- let addItem item dict =
- let groupItems = Dict.get (f item) dict |> Maybe.withDefault []
- in Dict.insert (f item) (item :: groupItems) dict
- in List.foldr addItem Dict.empty xs
- |> Dict.toList
-
-mean : List Int -> Int
-mean xs = (List.sum xs) // (List.length xs)
-
-links : List a -> List (a, a)
-links xs =
- let reversed = List.reverse xs
- in List.foldr
- (\x acc ->
- case Maybe.map Tuple.first (List.head acc) of
- Just y ->
- (x, y) :: acc
- _ ->
- acc
- )
- (case reversed of
- x :: y :: _ -> [(y, x)]
- _ -> []
- )
- (List.reverse << List.drop 2 <| reversed)
diff --git a/src/client/Utils/Search.elm b/src/client/Utils/Search.elm
deleted file mode 100644
index 1b70387..0000000
--- a/src/client/Utils/Search.elm
+++ /dev/null
@@ -1,10 +0,0 @@
-module Utils.Search exposing
- ( format
- )
-
-import String
-
-import Utils.String as String
-
-format : String -> String
-format = String.unaccent << String.toLower
diff --git a/src/client/Utils/String.elm b/src/client/Utils/String.elm
deleted file mode 100644
index 90fe68e..0000000
--- a/src/client/Utils/String.elm
+++ /dev/null
@@ -1,38 +0,0 @@
-module Utils.String exposing
- ( unaccent
- )
-
-unaccent : String -> String
-unaccent = String.map unaccentChar
-
-unaccentChar : Char -> Char
-unaccentChar c = case c of
- 'à' -> 'a'
- 'á' -> 'a'
- 'â' -> 'a'
- 'ã' -> 'a'
- 'ä' -> 'a'
- 'ç' -> 'c'
- 'è' -> 'e'
- 'é' -> 'e'
- 'ê' -> 'e'
- 'ë' -> 'e'
- 'ì' -> 'i'
- 'í' -> 'i'
- 'î' -> 'i'
- 'ï' -> 'i'
- 'ñ' -> 'n'
- 'ò' -> 'o'
- 'ó' -> 'o'
- 'ô' -> 'o'
- 'õ' -> 'o'
- 'ö' -> 'o'
- 'š' -> 's'
- 'ù' -> 'u'
- 'ú' -> 'u'
- 'û' -> 'u'
- 'ü' -> 'u'
- 'ý' -> 'y'
- 'ÿ' -> 'y'
- 'ž' -> 'z'
- _ -> c
diff --git a/src/client/Validation.elm b/src/client/Validation.elm
deleted file mode 100644
index de27963..0000000
--- a/src/client/Validation.elm
+++ /dev/null
@@ -1,65 +0,0 @@
-module Validation exposing
- ( cost
- , date
- , category
- , color
- , new
- )
-
-import Date exposing (Date)
-import Date.Extra.Core exposing (intToMonth)
-import Date.Extra.Create exposing (dateFromFields)
-import Dict
-import Regex
-import String exposing (toInt, split)
-
-import Form.Validate as Validate exposing (Validation)
-import Form.Error as Error exposing (ErrorValue(CustomError))
-
-import Model.Category exposing (Categories, CategoryId)
-
-cost : Validation String Int
-cost =
- Validate.customValidation Validate.int (\n ->
- if n == 0
- then Err (Validate.customError "CostMustNotBeNull")
- else Ok n
- )
-
-date : Validation String Date
-date =
- Validate.customValidation Validate.string (\str ->
- case split "/" str of
- [day, month, year] ->
- case (toInt day, toInt month, toInt year) of
- (Ok dayNum, Ok monthNum, Ok yearNum) ->
- Ok (dateFromFields yearNum (intToMonth monthNum) dayNum 0 0 0 0)
- _ -> Err (Validate.customError "InvalidDate")
- _ -> Err (Validate.customError "InvalidDate")
- )
-
-category : Categories -> Validation String CategoryId
-category categories =
- Validate.customValidation Validate.string (\str ->
- case toInt str of
- Ok category ->
- if List.member category (Dict.keys categories)
- then Ok category
- else Err (Validate.customError "InvalidCategory")
- Err _ ->
- Err (Validate.customError "InvalidCategory")
- )
-
-color : Validation String String
-color =
- Validate.customValidation Validate.string (\str ->
- if Regex.contains (Regex.regex "^#[0-9a-fA-F]{6}$") str
- then Ok str
- else Err (Validate.customError "InvalidColor")
- )
-
-new : List x -> x -> Validation String x
-new xs x field =
- if List.member x xs
- then Err (Error.value <| CustomError "AlreadyExists")
- else Ok x
diff --git a/src/client/View.elm b/src/client/View.elm
deleted file mode 100644
index deee272..0000000
--- a/src/client/View.elm
+++ /dev/null
@@ -1,34 +0,0 @@
-module View exposing
- ( view
- )
-
-import Html exposing (..)
-import Html.Attributes exposing (..)
-
-import Model exposing (Model)
-import Msg exposing (Msg)
-import Model.View exposing (..)
-import LoggedData
-import Dialog
-import Tooltip
-
-import View.Header as Header
-import View.Errors as Errors
-
-import SignIn.View as SignInView
-import LoggedIn.View as LoggedInView
-
-view : Model -> Html Msg
-view model =
- div
- []
- [ Header.view model
- , case model.view of
- SignInView signIn ->
- SignInView.view model signIn
- LoggedInView loggedIn ->
- LoggedInView.view model loggedIn
- , Errors.view model.translations model.errors
- , Dialog.view model.dialog
- , Html.map Msg.Tooltip <| Tooltip.view model.tooltip
- ]
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