...
 
Commits (3)
## Income view
- Clone an income
- Edit an income
- Remove an income
## Payment
- Use income table factorizations
## Category view
- Show the category table
......@@ -12,9 +15,9 @@
- Edit a category
- Remove a category
## Mobile
## Slow
- Slow, consider native ? consider doing more work on the server ?
- Implement server side paging
# Additional features
......
......@@ -20,6 +20,7 @@ Executable client
MultiParamTypeClasses
OverloadedStrings
RecursiveDo
ScopedTypeVariables
Build-depends:
aeson
......@@ -44,7 +45,6 @@ Executable client
, uri-bytestring
other-modules:
Component
Component.Button
Component.Form
Component.Input
......
module Component (module X) where
import Component.Button as X
import Component.Form as X
import Component.Input as X
import Component.Link as X
import Component.Pages as X
import Component.Select as X
import Component.Table as X
module Component.Button
( ButtonIn(..)
, ButtonOut(..)
, button
, defaultButtonIn
( In(..)
, Out(..)
, view
, defaultIn
) where
import qualified Data.Map as M
......@@ -14,44 +14,44 @@ import qualified Reflex.Dom as R
import qualified View.Icon as Icon
data ButtonIn t m = ButtonIn
{ _buttonIn_class :: Dynamic t Text
, _buttonIn_content :: m ()
, _buttonIn_waiting :: Event t Bool
, _buttonIn_tabIndex :: Maybe Int
, _buttonIn_submit :: Bool
data In t m = In
{ _in_class :: Dynamic t Text
, _in_content :: m ()
, _in_waiting :: Event t Bool
, _in_tabIndex :: Maybe Int
, _in_submit :: Bool
}
defaultButtonIn :: MonadWidget t m => m () -> ButtonIn t m
defaultButtonIn content = ButtonIn
{ _buttonIn_class = R.constDyn ""
, _buttonIn_content = content
, _buttonIn_waiting = R.never
, _buttonIn_tabIndex = Nothing
, _buttonIn_submit = False
defaultIn :: MonadWidget t m => m () -> In t m
defaultIn content = In
{ _in_class = R.constDyn ""
, _in_content = content
, _in_waiting = R.never
, _in_tabIndex = Nothing
, _in_submit = False
}
data ButtonOut t = ButtonOut
{ _buttonOut_clic :: Event t ()
data Out t = Out
{ _out_clic :: Event t ()
}
button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t)
button buttonIn = do
dynWaiting <- R.holdDyn False $ _buttonIn_waiting buttonIn
view :: forall t m. MonadWidget t m => In t m -> m (Out t)
view input = do
dynWaiting <- R.holdDyn False $ _in_waiting input
let attr = do
buttonClass <- _buttonIn_class buttonIn
buttonClass <- _in_class input
waiting <- dynWaiting
return . M.fromList . catMaybes $
[ Just ("type", if _buttonIn_submit buttonIn then "submit" else "button")
, (\i -> ("tabindex", T.pack . show $ i)) <$> _buttonIn_tabIndex buttonIn
[ Just ("type", if _in_submit input then "submit" else "button")
, (\i -> ("tabindex", T.pack . show $ i)) <$> _in_tabIndex input
, Just ("class", T.intercalate " " [ buttonClass, if waiting then "waiting" else "" ])
]
(e, _) <- R.elDynAttr' "button" attr $ do
Icon.loading
R.divClass "content" $ _buttonIn_content buttonIn
R.divClass "content" $ _in_content input
return $ ButtonOut
{ _buttonOut_clic = R.domEvent R.Click e
return $ Out
{ _out_clic = R.domEvent R.Click e
}
module Component.Form
( form
( view
) where
import qualified Data.Map as M
import Reflex.Dom (MonadWidget)
import qualified Reflex.Dom as R
form :: forall t m a. MonadWidget t m => m a -> m a
form content =
view :: forall t m a. MonadWidget t m => m a -> m a
view content =
R.elAttr "form" (M.singleton "onsubmit" "event.preventDefault()") $
content
module Component.Input
( InputIn(..)
, InputOut(..)
, input
, defaultInputIn
( In(..)
, Out(..)
, view
, defaultIn
) where
import qualified Data.Map as M
......@@ -17,40 +17,39 @@ import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex,
import qualified Reflex.Dom as R
import qualified Common.Util.Validation as ValidationUtil
import Component.Button (ButtonIn (..), ButtonOut (..))
import qualified Component.Button as Button
import qualified View.Icon as Icon
data InputIn a = InputIn
{ _inputIn_hasResetButton :: Bool
, _inputIn_label :: Text
, _inputIn_initialValue :: Text
, _inputIn_inputType :: Text
, _inputIn_validation :: Text -> Validation Text a
data In a = In
{ _in_hasResetButton :: Bool
, _in_label :: Text
, _in_initialValue :: Text
, _in_inputType :: Text
, _in_validation :: Text -> Validation Text a
}
defaultInputIn :: InputIn Text
defaultInputIn = InputIn
{ _inputIn_hasResetButton = True
, _inputIn_label = ""
, _inputIn_initialValue = ""
, _inputIn_inputType = "text"
, _inputIn_validation = V.Success
defaultIn :: In Text
defaultIn = In
{ _in_hasResetButton = True
, _in_label = ""
, _in_initialValue = ""
, _in_inputType = "text"
, _in_validation = V.Success
}
data InputOut t a = InputOut
{ _inputOut_raw :: Dynamic t Text
, _inputOut_value :: Dynamic t (Validation Text a)
, _inputOut_enter :: Event t ()
data Out t a = Out
{ _out_raw :: Dynamic t Text
, _out_value :: Dynamic t (Validation Text a)
, _out_enter :: Event t ()
}
input
view
:: forall t m a b. MonadWidget t m
=> InputIn a
=> In a
-> Event t Text -- reset
-> Event t b -- validate
-> m (InputOut t a)
input inputIn reset validate = do
-> m (Out t a)
view input reset validate = do
rec
let resetValue = R.leftmost
[ reset
......@@ -58,7 +57,7 @@ input inputIn reset validate = do
]
inputAttr = R.ffor value (\v ->
if T.null v && _inputIn_inputType inputIn /= "date"
if T.null v && _in_inputType input /= "date"
then M.empty
else M.singleton "class" "filled")
......@@ -70,7 +69,7 @@ input inputIn reset validate = do
, if Maybe.isJust e then "error" else ""
])
let valueWithValidation = R.ffor value (\v -> (v, _inputIn_validation inputIn $ v))
let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v))
inputError <- getInputError valueWithValidation validate
(textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
......@@ -79,21 +78,21 @@ input inputIn reset validate = do
textInput <- R.textInput $ R.def
& R.attributes .~ inputAttr
& R.setValue .~ resetValue
& R.textInputConfig_initialValue .~ (_inputIn_initialValue inputIn)
& R.textInputConfig_inputType .~ (_inputIn_inputType inputIn)
& R.textInputConfig_initialValue .~ (_in_initialValue input)
& R.textInputConfig_inputType .~ (_in_inputType input)
R.divClass "label" $
R.text (_inputIn_label inputIn)
R.text (_in_label input)
return textInput
resetClic <-
if _inputIn_hasResetButton inputIn
if _in_hasResetButton input
then
_buttonOut_clic <$> (Button.button $
(Button.defaultButtonIn Icon.cross)
{ _buttonIn_class = R.constDyn "reset"
, _buttonIn_tabIndex = Just (-1)
Button._out_clic <$> (Button.view $
(Button.defaultIn Icon.cross)
{ Button._in_class = R.constDyn "reset"
, Button._in_tabIndex = Just (-1)
})
else
return R.never
......@@ -105,10 +104,10 @@ input inputIn reset validate = do
let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
return $ InputOut
{ _inputOut_raw = value
, _inputOut_value = fmap snd valueWithValidation
, _inputOut_enter = enter
return $ Out
{ _out_raw = value
, _out_value = fmap snd valueWithValidation
, _out_enter = enter
}
getInputError
......
module Component.Link
( link
( view
) where
import Data.Map (Map)
......@@ -9,8 +9,8 @@ import qualified Data.Text as T
import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
link :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m ()
link href inputAttrs content =
view :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> Text -> m ()
view href inputAttrs content =
R.elDynAttr "a" attrs (R.text content)
where
......
module Component.Modal
( Input(..)
( In(..)
, Content
, view
) where
......@@ -22,15 +22,15 @@ import qualified Util.Reflex as ReflexUtil
-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
type Content t m a = Event t () -> m (Event t (), Event t a)
data Input t m a = Input
{ _input_show :: Event t ()
, _input_content :: Content t m a
data In t m a = In
{ _in_show :: Event t ()
, _in_content :: Content t m a
}
view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a)
view :: forall t m a. MonadWidget t m => In t m a -> m (Event t a)
view input = do
rec
let show = Show <$ (_input_show input)
let show = Show <$ (_in_show input)
startHiding =
R.attachWithMaybe
......@@ -61,7 +61,7 @@ view input = do
(do
(curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
let curtainClick = R.domEvent R.Click curtain
(hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick)
(hide, content) <- R.divClass "g-Modal__Content" (_in_content input curtainClick)
return (curtainClick, hide, content))
......
module Component.ModalForm
( view
, In(..)
, Out(..)
) where
import Data.Aeson (ToJSON)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Data.Validation (Validation)
import qualified Data.Validation as V
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Common.Msg as Msg
import qualified Component.Button as Button
import qualified Util.Either as EitherUtil
import qualified Util.Validation as ValidationUtil
import qualified Util.WaitFor as WaitFor
data In m t a b e = In
{ _in_headerLabel :: Text
, _in_form :: m (Dynamic t (Validation e a))
, _in_ajax :: Event t a -> m (Event t (Either Text b))
}
data Out t a = Out
{ _out_hide :: Event t ()
, _out_cancel :: Event t ()
, _out_confirm :: Event t ()
, _out_validate :: Event t a
}
view :: forall t m a b e. (MonadWidget t m, ToJSON a) => In m t a b e -> m (Out t b)
view input =
R.divClass "form" $ do
R.divClass "formHeader" $
R.text (_in_headerLabel input)
R.divClass "formContent" $ do
rec
form <- _in_form input
(validate, cancel, confirm) <- R.divClass "buttons" $ do
rec
cancel <- Button._out_clic <$> (Button.view $
(Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
{ Button._in_class = R.constDyn "undo" })
confirm <- Button._out_clic <$> (Button.view $
(Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
{ Button._in_class = R.constDyn "confirm"
, Button._in_waiting = waiting
, Button._in_submit = True
})
(validate, waiting) <- WaitFor.waitFor
(_in_ajax input)
(ValidationUtil.fireValidation form confirm)
return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
return Out
{ _out_hide = R.leftmost [ cancel, () <$ validate ]
, _out_cancel = cancel
, _out_confirm = confirm
, _out_validate = validate
}
module Component.Pages
( widget
, PagesIn(..)
, PagesOut(..)
( view
, In(..)
, Out(..)
) where
import qualified Data.Text as T
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Component.Button (ButtonIn (..), ButtonOut (..))
import qualified Component.Button as Button
import qualified Util.Reflex as ReflexUtil
import qualified View.Icon as Icon
data PagesIn t = PagesIn
{ _pagesIn_total :: Dynamic t Int
, _pagesIn_perPage :: Int
, _pagesIn_reset :: Event t ()
data In t = In
{ _in_total :: Dynamic t Int
, _in_perPage :: Int
, _in_reset :: Event t ()
}
data PagesOut t = PagesOut
{ _pagesOut_currentPage :: Dynamic t Int
data Out t = Out
{ _out_currentPage :: Dynamic t Int
}
widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t)
widget pagesIn = do
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input = do
currentPage <- ReflexUtil.divVisibleIf ((> 0) <$> total) $ pageButtons total perPage reset
return $ PagesOut
{ _pagesOut_currentPage = currentPage
return $ Out
{ _out_currentPage = currentPage
}
where
total = _pagesIn_total pagesIn
perPage = _pagesIn_perPage pagesIn
reset = _pagesIn_reset pagesIn
total = _in_total input
perPage = _in_perPage input
reset = _in_reset input
pageButtons :: forall t m. MonadWidget t m => Dynamic t Int -> Int -> Event t () -> m (Dynamic t Int)
pageButtons total perPage reset = do
......@@ -75,14 +74,14 @@ range currentPage maxPage = [start..end]
pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int)
pageButton currentPage page content = do
clic <- _buttonOut_clic <$> (Button.button $ ButtonIn
{ _buttonIn_class = do
clic <- Button._out_clic <$> (Button.view $ Button.In
{ Button._in_class = do
cp <- currentPage
p <- page
if cp == Just p then "page current" else "page"
, _buttonIn_content = content
, _buttonIn_waiting = R.never
, _buttonIn_tabIndex = Nothing
, _buttonIn_submit = False
, Button._in_content = content
, Button._in_waiting = R.never
, Button._in_tabIndex = Nothing
, Button._in_submit = False
})
return . fmap fst $ R.attach (R.current page) clic
module Component.Select
( SelectIn(..)
, SelectOut(..)
, select
( view
, In(..)
, Out(..)
) where
import Data.Map (Map)
......@@ -15,58 +15,58 @@ import qualified Reflex.Dom as R
import qualified Util.Validation as ValidationUtil
data (Reflex t) => SelectIn t a b c = SelectIn
{ _selectIn_label :: Text
, _selectIn_initialValue :: a
, _selectIn_value :: Event t a
, _selectIn_values :: Dynamic t (Map a Text)
, _selectIn_reset :: Event t b
, _selectIn_isValid :: a -> Validation Text a
, _selectIn_validate :: Event t c
data (Reflex t) => In t a b c = In
{ _in_label :: Text
, _in_initialValue :: a
, _in_value :: Event t a
, _in_values :: Dynamic t (Map a Text)
, _in_reset :: Event t b
, _in_isValid :: a -> Validation Text a
, _in_validate :: Event t c
}
data SelectOut t a = SelectOut
{ _selectOut_raw :: Dynamic t a
, _selectOut_value :: Dynamic t (Validation Text a)
data Out t a = Out
{ _out_raw :: Dynamic t a
, _out_value :: Dynamic t (Validation Text a)
}
select :: forall t m a b c. (Ord a, MonadWidget t m) => SelectIn t a b c -> m (SelectOut t a)
select selectIn = do
view :: forall t m a b c. (Ord a, MonadWidget t m) => In t a b c -> m (Out t a)
view input = do
rec
let containerAttr = R.ffor showedError (\e ->
M.singleton "class" $ T.intercalate " "
[ "selectInput"
[ "input"
, if Maybe.isJust e then "error" else ""
])
validatedValue =
fmap (_selectIn_isValid selectIn) value
fmap (_in_isValid input) value
maybeError =
fmap ValidationUtil.maybeError validatedValue
showedError <- R.holdDyn Nothing $ R.leftmost
[ Nothing <$ _selectIn_reset selectIn
[ Nothing <$ _in_reset input
, R.updated maybeError
, R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
, R.attachWith const (R.current maybeError) (_in_validate input)
]
value <- R.elDynAttr "div" containerAttr $ do
let initialValue = _selectIn_initialValue selectIn
let initialValue = _in_initialValue input
let setValue = R.leftmost
[ initialValue <$ (_selectIn_reset selectIn)
, _selectIn_value selectIn
[ initialValue <$ (_in_reset input)
, _in_value input
]
value <- R.el "label" $ do
R.divClass "label" $
R.text (_selectIn_label selectIn)
R.text (_in_label input)
R._dropdown_value <$>
R.dropdown
initialValue
(_selectIn_values selectIn)
(_in_values input)
(R.def { R._dropdownConfig_setValue = setValue })
R.divClass "errorMessage" . R.dynText $
......@@ -74,7 +74,7 @@ select selectIn = do
return value
return SelectOut
{ _selectOut_raw = value
, _selectOut_value = validatedValue
return Out
{ _out_raw = value
, _out_value = validatedValue
}
module Component.Table
( table
, TableIn(..)
, TableOut(..)
( view
, In(..)
, Out(..)
) where
import Data.Text (Text)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Data.Text (Text)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Component.Pages (PagesIn (..), PagesOut (..))
import qualified Component.Pages as Pages
import qualified Component.Button as Button
import qualified Component.Modal as Modal
import qualified Component.Pages as Pages
import qualified Util.Reflex as ReflexUtil
import qualified View.Icon as Icon
data TableIn h r t = TableIn
{ _tableIn_headerLabel :: h -> Text
, _tableIn_rows :: Dynamic t [r]
, _tableIn_cell :: h -> r -> Text
, _tableIn_perPage :: Int
, _tableIn_resetPage :: Event t ()
data In m t h r a = In
{ _in_headerLabel :: h -> Text
, _in_rows :: Dynamic t [r]
, _in_cell :: h -> r -> Text
, _in_perPage :: Int
, _in_resetPage :: Event t ()
, _in_cloneModal :: Dynamic t r -> Modal.Content t m a
}
data TableOut = TableOut
{}
data Out t a = Out
{ _out_add :: Event t a
}
table :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => TableIn h r t -> m (TableOut)
table tableIn =
view :: forall t m h r a. (MonadWidget t m, Bounded h, Enum h) => In m t h r a -> m (Out t a)
view input =
R.divClass "table" $ do
rec
R.divClass "lines" $ do
result <- R.divClass "lines" $ do
R.divClass "header" $
R.divClass "header" $ do
flip mapM_ [minBound..] $ \header ->
R.divClass "cell" . R.text $
_tableIn_headerLabel tableIn header
_in_headerLabel input header
R.divClass "cell" $ R.blank
let rows = getRange
(_tableIn_perPage tableIn)
<$> (_pagesOut_currentPage pages)
<*> (_tableIn_rows tableIn)
(_in_perPage input)
<$> (Pages._out_currentPage pages)
<*> (_in_rows input)
R.simpleList rows $ \r ->
R.divClass "row" $
R.divClass "row" $ do
flip mapM_ [minBound..] $ \h ->
R.divClass "cell name" $
R.divClass "cell" $
R.dynText $
R.ffor r (_tableIn_cell tableIn h)
R.ffor r (_in_cell input h)
clone <-
R.divClass "cell button" $
Button._out_clic <$> (Button.view $
Button.defaultIn Icon.clone)
cloned <-
Modal.view $ Modal.In
{ Modal._in_show = clone
, Modal._in_content = _in_cloneModal input r
}
return cloned
pages <- Pages.widget $ PagesIn
{ _pagesIn_total = length <$> (_tableIn_rows tableIn)
, _pagesIn_perPage = _tableIn_perPage tableIn
, _pagesIn_reset = _tableIn_resetPage tableIn
pages <- Pages.view $ Pages.In
{ Pages._in_total = length <$> (_in_rows input)
, Pages._in_perPage = _in_perPage input
, Pages._in_reset = _in_resetPage input
}
return ()
-- return $
-- ( R.switch . R.current . fmap (R.leftmost . map (\(a, _, _) -> a)) $ result
-- , R.switch . R.current . fmap (R.leftmost . map (\(_, b, _) -> b)) $ result
-- , R.switch . R.current . fmap (R.leftmost . map (\(_, _, c) -> c)) $ result
-- )
return $ TableOut
{}
return $ Out
{ _out_add = R.switch . R.current . fmap R.leftmost $ result
}
getRange :: forall a. Int -> Int -> [a] -> [a]
getRange perPage currentPage =
......
......@@ -13,12 +13,9 @@ import qualified Common.Msg as Msg
import Model.Route (Route (..))
import qualified Util.Router as Router
import View.Header (HeaderIn (..))
import qualified View.Header as Header
import View.Income.Income (IncomeIn (..))
import qualified View.Income.Income as Income
import qualified View.NotFound as NotFound
import View.Payment.Payment (PaymentIn (..))
import qualified View.Payment.Payment as Payment
import qualified View.SignIn as SignIn
......@@ -28,17 +25,17 @@ widget initResult =
route <- getRoute
headerOut <- Header.view $ HeaderIn
{ _headerIn_initResult = initResult
, _headerIn_isInitSuccess =
header <- Header.view $ Header.In
{ Header._in_initResult = initResult
, Header._in_isInitSuccess =
case initResult of
InitSuccess _ -> True
_ -> False
, _headerIn_route = route
, Header._in_route = route
}
let signOut =
Header._headerOut_signOut headerOut
Header._out_signOut header
mainContent =
case initResult of
......@@ -63,17 +60,17 @@ signedWidget init route = do
R.dyn . R.ffor route $ \case
RootRoute -> do
paymentInit <- Payment.init
Payment.view $ PaymentIn
{ _paymentIn_currentUser = _init_currentUser init
, _paymentIn_currency = _init_currency init
, _paymentIn_init = paymentInit
Payment.view $ Payment.In
{ Payment._in_currentUser = _init_currentUser init
, Payment._in_currency = _init_currency init
, Payment._in_init = paymentInit
}
IncomeRoute -> do
incomeInit <- Income.init
Income.view $ IncomeIn
{ _incomeIn_currency = _init_currency init
, _incomeIn_init = incomeInit
Income.view $ Income.In
{ Income._in_currency = _init_currency init
, Income._in_init = incomeInit
}
NotFoundRoute ->
......
module View.Header
( view
, HeaderIn(..)
, HeaderOut(..)
, In(..)
, Out(..)
) where
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime)
import Prelude hiding (error, init)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Init (..), InitResult (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import Component (ButtonIn (..))
import qualified Component as Component
import Model.Route (Route (..))
import qualified Util.Css as CssUtil
import qualified Util.Reflex as ReflexUtil
import qualified View.Icon as Icon
data HeaderIn t = HeaderIn
{ _headerIn_initResult :: InitResult
, _headerIn_isInitSuccess :: Bool
, _headerIn_route :: Dynamic t Route
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime)
import Prelude hiding (error, init)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Init (..), InitResult (..), User (..))
import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Component.Button as Button
import qualified Component.Link as Link
import Model.Route (Route (..))
import qualified Util.Css as CssUtil
import qualified Util.Reflex as ReflexUtil
import qualified View.Icon as Icon
data In t = In
{ _in_initResult :: InitResult
, _in_isInitSuccess :: Bool
, _in_route :: Dynamic t Route
}
data HeaderOut t = HeaderOut
{ _headerOut_signOut :: Event t ()
data Out t = Out
{ _out_signOut :: Event t ()
}
view :: forall t m. MonadWidget t m => (HeaderIn t) -> m (HeaderOut t)
view headerIn =
view :: forall t m. MonadWidget t m => (In t) -> m (Out t)
view input =
R.el "header" $ do
R.divClass "title" $
......@@ -42,23 +42,23 @@ view headerIn =
signOut <- R.el "div" $ do
rec
showLinks <- R.foldDyn const (_headerIn_isInitSuccess headerIn) (False <$ signOut)
ReflexUtil.visibleIfDyn showLinks R.blank (links $ _headerIn_route headerIn)
signOut <- nameSignOut $ _headerIn_initResult headerIn
showLinks <- R.foldDyn const (_in_isInitSuccess input) (False <$ signOut)
ReflexUtil.visibleIfDyn showLinks R.blank (links $ _in_route input)
signOut <- nameSignOut $ _in_initResult input
return signOut
return $ HeaderOut
{ _headerOut_signOut = signOut
return $ Out
{ _out_signOut = signOut
}
links :: forall t m. MonadWidget t m => Dynamic t Route -> m ()
links route = do
Component.link
Link.view
"/"
(R.ffor route (attrs RootRoute))
(Msg.get Msg.Payment_Title)
Component.link
Link.view
"/income"
(R.ffor route (attrs IncomeRoute))
(Msg.get Msg.Income_Title)
......@@ -92,12 +92,12 @@ nameSignOut initResult = case initResult of
signOutButton :: forall t m. MonadWidget t m => m (Event t ())
signOutButton = do
rec
signOut <- Component.button $
(Component.defaultButtonIn Icon.signOut)
{ _buttonIn_class = R.constDyn "signOut item"
, _buttonIn_waiting = waiting
signOut <- Button.view $
(Button.defaultIn Icon.signOut)
{ Button._in_class = R.constDyn "signOut item"
, Button._in_waiting = waiting
}
let signOutClic = Component._buttonOut_clic signOut
let signOutClic = Button._out_clic signOut
waiting = R.leftmost
[ fmap (const True) signOutClic
, fmap (const False) signOutSuccess
......
module View.Income.Add
( view
, In(..)
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.Maybe as Maybe
import qualified Data.Text as T
import qualified Data.Time.Clock as Time
import Reflex.Dom (MonadWidget)
import Reflex.Dom (Dynamic, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (CreateIncomeForm (..), Income)
import Common.Model (CreateIncomeForm (..), Income (..))
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import View.Income.Form (FormIn (..), FormOut (..))
import qualified View.Income.Form as Form
view :: forall t m. MonadWidget t m => Modal.Content t m Income
view cancel = do
data In t = In
{ _in_income :: Dynamic t (Maybe Income)
}
view :: forall t m. MonadWidget t m => In t -> Modal.Content t m Income
view input cancel = do
currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
form <- R.dyn $
return $ Form.view $ FormIn
{ _formIn_cancel = cancel
, _formIn_headerLabel = Msg.get Msg.Income_AddLong
, _formIn_amount = ""
, _formIn_date = currentDay
, _formIn_mkPayload = CreateIncomeForm
, _formIn_httpMethod = Form.Post
form <- R.dyn $ do
income <- _in_income input
return $ Form.view $ Form.In
{ Form._in_cancel = cancel
, Form._in_headerLabel = Msg.get Msg.Income_AddLong
, Form._in_amount = Maybe.fromMaybe "" ((T.pack . show . _income_amount) <$> income)
, Form._in_date = currentDay
, Form._in_mkPayload = CreateIncomeForm
, Form._in_ajax = Ajax.post
}
hide <- ReflexUtil.flatten (_formOut_hide <$> form)
addIncome <- ReflexUtil.flatten (_formOut_addIncome <$> form)
hide <- ReflexUtil.flatten (Form._out_hide <$> form)
addIncome <- ReflexUtil.flatten (Form._out_addIncome <$> form)
return (hide, addIncome)
module View.Income.Form
( view
, FormIn(..)
, HttpMethod(..)
, FormOut(..)
, In(..)
, Out(..)
) where
import Data.Aeson (ToJSON)
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Time.Calendar as Calendar
import Data.Validation (Validation)
import qualified Data.Validation as V
import Reflex.Dom (Event, MonadWidget)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Income)
import qualified Common.Msg as Msg
import qualified Common.Validation.Income as IncomeValidation
import Component (ButtonIn (..), InputIn (..),
InputOut (..))
import qualified Component as Component
import qualified Util.Ajax as Ajax
import qualified Util.Either as EitherUtil
import qualified Util.Validation as ValidationUtil
import qualified Util.WaitFor as WaitFor
data FormIn t i = FormIn
{ _formIn_cancel :: Event t ()
, _formIn_headerLabel :: Text
, _formIn_amount :: Text
, _formIn_date :: Day
, _formIn_mkPayload :: Text -> Text -> i
, _formIn_httpMethod :: HttpMethod
import qualified Component.Input as Input
import qualified Component.ModalForm as ModalForm
data In m t a = In
{ _in_cancel :: Event t ()
, _in_headerLabel :: Text
, _in_amount :: Text
, _in_date :: Day
, _in_mkPayload :: Text -> Text -> a
, _in_ajax :: Text -> Event t a -> m (Event t (Either Text Income))
}
data HttpMethod = Put | Post
data FormOut t = FormOut
{ _formOut_hide :: Event t ()
, _formOut_addIncome :: Event t Income
data Out t = Out
{ _out_hide :: Event t ()
, _out_addIncome :: Event t Income
}
view :: forall t m i. (MonadWidget t m, ToJSON i) => FormIn t i -> m (FormOut t)
view formIn = do
R.divClass "form" $ do
R.divClass "formHeader" $
R.text (_formIn_headerLabel formIn)
R.divClass "formContent" $ do
rec
let reset = R.leftmost
[ "" <$ cancel
, "" <$ addIncome
, "" <$ _formIn_cancel formIn
]
amount <- _inputOut_raw <$> (Component.input
(Component.defaultInputIn
{ _inputIn_label = Msg.get Msg.Income_Amount
, _inputIn_initialValue = _formIn_amount formIn
, _inputIn_validation = IncomeValidation.amount
})
(_formIn_amount formIn <$ reset)
confirm)
let initialDate = T.pack . Calendar.showGregorian . _formIn_date $ formIn
date <- _inputOut_raw <$> (Component.input
(Component.defaultInputIn
{ _inputIn_label = Msg.get Msg.Income_Date
, _inputIn_initialValue = initialDate
, _inputIn_inputType = "date"
, _inputIn_hasResetButton = False
, _inputIn_validation = IncomeValidation.date
})
(initialDate <$ reset)
confirm)
let income = do
a <- amount
d <- date
return . V.Success $ (_formIn_mkPayload formIn) a d
(addIncome, cancel, confirm) <- R.divClass "buttons" $ do
rec
cancel <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
{ _buttonIn_class = R.constDyn "undo" })
confirm <- Component._buttonOut_clic <$> (Component.button $
(Component.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
{ _buttonIn_class = R.constDyn "confirm"
, _buttonIn_waiting = waiting
, _buttonIn_submit = True
})
(addIncome, waiting) <- WaitFor.waitFor
(ajax "/api/income")
(ValidationUtil.fireValidation income confirm)
return (R.fmapMaybe EitherUtil.eitherToMaybe addIncome, cancel, confirm)
return FormOut
{ _formOut_hide = R.leftmost [ cancel, () <$ addIncome ]
, _formOut_addIncome = addIncome
}
view :: forall t m a. (MonadWidget t m, ToJSON a) => In m t a -> m (Out t)
view input = do
rec
let reset = R.leftmost
[ "" <$ ModalForm._out_cancel modalForm
, "" <$ ModalForm._out_validate modalForm
, "" <$ _in_cancel input
]
modalForm <- ModalForm.view $ ModalForm.In
{ ModalForm._in_headerLabel = _in_headerLabel input
, ModalForm._in_ajax = _in_ajax input "/api/income"
, ModalForm._in_form = form reset (ModalForm._out_confirm modalForm)
}
return $ Out
{ _out_hide = ModalForm._out_hide modalForm
, _out_addIncome = ModalForm._out_validate modalForm
}
where
ajax =
case _formIn_httpMethod formIn of
Post -> Ajax.post
Put -> Ajax.put
form
:: Event t String
-> Event t ()
-> m (Dynamic t (Validation Text a))
form reset confirm = do
amount <- Input._out_raw <$> (Input.view
(Input.defaultIn
{ Input._in_label = Msg.get Msg.Income_Amount
, Input._in_initialValue = _in_amount input
, Input._in_validation = IncomeValidation.amount
})
(_in_amount input <$ reset)
confirm)
let initialDate = T.pack . Calendar.showGregorian . _in_date $ input
date <- Input._out_raw <$> (Input.view
(Input.defaultIn
{ Input._in_label = Msg.get Msg.Income_Date
, Input._in_initialValue = initialDate
, Input._in_inputType = "date"
, Input._in_hasResetButton = False
, Input._in_validation = IncomeValidation.date
})
(initialDate <$ reset)
confirm)
return $ do
a <- amount
d <- date
return . V.Success $ (_in_mkPayload input) a d
module View.Income.Header
( view
, HeaderIn(..)
, HeaderOut(..)
, In(..)
, Out(..)
) where
import Control.Monad.IO.Class (liftIO)
......@@ -16,25 +16,24 @@ import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import Component (ButtonOut (..))
import qualified Component
import qualified Component.Button as Button
import qualified Component.Modal as Modal
import qualified Util.Date as DateUtil
import qualified View.Income.Add as Add
import View.Income.Init (Init (..))
data HeaderIn t = HeaderIn
{ _headerIn_init :: Init
, _headerIn_currency :: Currency
, _headerIn_incomes :: Dynamic t [Income]
data In t = In
{ _in_init :: Init
, _in_currency :: Currency
, _in_incomes :: Dynamic t [Income]
}
data HeaderOut t = HeaderOut
{ _headerOut_addIncome :: Event t Income
data Out t = Out
{ _out_addIncome :: Event t Income
}
view :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t)
view headerIn =
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input =
R.divClass "withMargin" $ do
currentTime <- liftIO Clock.getCurrentTime
......@@ -58,7 +57,7 @@ view headerIn =
T.intercalate " "
[ _user_name user
, "−"
, Format.price (_headerIn_currency headerIn) $
, Format.price (_in_currency input) $
CM.cumulativeIncomesSince currentTime since userIncomes
]
......@@ -67,23 +66,23 @@ view headerIn =
R.text $
Msg.get Msg.Income_MonthlyNet
addIncome <- _buttonOut_clic <$>
(Component.button . Component.defaultButtonIn . R.text $
addIncome <- Button._out_clic <$>
(Button.view . Button.defaultIn . R.text $
Msg.get Msg.Income_AddLong)
addIncome <- Modal.view $ Modal.Input
{ Modal._input_show = addIncome
, Modal._input_content = Add.view
addIncome <- Modal.view $ Modal.In
{ Modal._in_show = addIncome
, Modal._in_content = Add.view $ Add.In { Add._in_income = R.constDyn Nothing }
}
return $ HeaderOut
{ _headerOut_addIncome = addIncome
return $ Out
{ _out_addIncome = addIncome
}
where
init = _headerIn_init headerIn
init = _in_init input
useIncomesFrom = R.ffor (_headerIn_incomes headerIn) $ \incomes ->
useIncomesFrom = R.ffor (_in_incomes input) $ \incomes ->
( CM.useIncomesFrom
(map _user_id $_init_users init)
incomes
......
module View.Income.Income
( init
, view
, IncomeIn(..)
, In(..)
) where
import Data.Aeson (FromJSON)
......@@ -14,15 +14,13 @@ import Common.Model (Currency)
import Loadable (Loadable (..))
import qualified Loadable
import qualified Util.Ajax as AjaxUtil
import View.Income.Header (HeaderIn (..), HeaderOut (..))
import qualified View.Income.Header as Header
import View.Income.Init (Init (..))
import View.Income.Table (IncomeTableIn (..))
import qualified View.Income.Table as Table
data IncomeIn t = IncomeIn
{ _incomeIn_currency :: Currency
, _incomeIn_init :: Dynamic t (Loadable Init)
data In t = In
{ _in_currency :: Currency
, _in_init :: Dynamic t (Loadable Init)
}
init :: forall t m. MonadWidget t m => m (Dynamic t (Loadable Init))
......@@ -36,30 +34,33 @@ init = do
ps <- payments
return $ Init <$> us <*> is <*> ps
view :: forall t m. MonadWidget t m => IncomeIn t -> m ()
view incomeIn = do
R.dyn . R.ffor (_incomeIn_init incomeIn) . Loadable.view $ \init ->
view :: forall t m. MonadWidget t m => In t -> m ()
view input = do
R.dyn . R.ffor (_in_init input) . Loadable.view $ \init ->
R.elClass "main" "income" $ do
rec
let addIncome = R.leftmost
[ Header._out_addIncome header
, Table._out_addIncome table
]
incomes <- R.foldDyn
(:)
(_init_incomes init)
(_headerOut_addIncome header)
addIncome
header <- Header.view $ HeaderIn
{ _headerIn_init = init
, _headerIn_currency = _incomeIn_currency incomeIn
, _headerIn_incomes = incomes
header <- Header.view $ Header.In
{ Header._in_init = init
, Header._in_currency = _in_currency input
, Header._in_incomes = incomes
}
Table.view $ IncomeTableIn
{ _tableIn_init = init
, _tableIn_currency = _incomeIn_currency incomeIn
, _tableIn_incomes = incomes
}
table <- Table.view $ Table.In
{ Table._in_init = init
, Table._in_currency = _in_currency input
, Table._in_incomes = incomes
}
return ()
......
module View.Income.Table
( view
, IncomeTableIn(..)
, In(..)
, Out(..)
) where
import qualified Data.List as L
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import Reflex.Dom (Dynamic, MonadWidget)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import Common.Model (Currency, Income (..), User (..))
......@@ -14,28 +15,38 @@ import qualified Common.Model as CM
import qualified Common.Msg as Msg
import qualified Common.View.Format as Format
import Component (TableIn (..))
import qualified Component
import qualified Component.Table as Table
import qualified View.Income.Add as Add
import View.Income.Init (Init (..))
data IncomeTableIn t = IncomeTableIn
{ _tableIn_init :: Init
, _tableIn_currency :: Currency
, _tableIn_incomes :: Dynamic t [Income]
data In t = In
{ _in_init :: Init
, _in_currency :: Currency
, _in_incomes :: Dynamic t [Income]
}
view :: forall t m. MonadWidget t m => IncomeTableIn t -> m ()
view tableIn = do
data Out t = Out
{ _out_addIncome :: Event t Income
}
view :: forall t m. MonadWidget t m => In t -> m (Out t)
view input = do
Component.table $ TableIn
{ _tableIn_headerLabel = headerLabel
, _tableIn_rows = R.ffor (_tableIn_incomes tableIn) $ reverse . L.sortOn _income_date
, _tableIn_cell = cell (_tableIn_init tableIn) (_tableIn_currency tableIn)
, _tableIn_perPage = 7
, _tableIn_resetPage = R.never
}
table <- Table.view $ Table.In
{ Table._in_headerLabel = headerLabel
, Table._in_rows = R.ffor (_in_incomes input) $ reverse . L.sortOn _income_date
, Table._in_cell = cell (_in_init input) (_in_currency input)
, Table._in_perPage = 7
, Table._in_resetPage = R.never
, Table._in_cloneModal = \income ->
Add.view $ Add.In
{ Add._in_income = Just <$> income
}
}
return ()
return $ Out
{ _out_addIncome = Table._out_add table
}
data Header
= UserHeader
......
......@@ -2,19 +2,19 @@ module View.NotFound
( view
) where
import qualified Data.Map as M
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Data.Map as M
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Common.Msg as Msg
import qualified Component as Component
import qualified Common.Msg as Msg
import qualified Component.Link as Link
view :: forall t m. MonadWidget t m => m ()
view =
R.divClass "notfound" $ do
R.text (Msg.get Msg.NotFound_Message)
Component.link
Link.view
"/"
(R.constDyn $ M.singleton "class" "link")
(Msg.get Msg.NotFound_LinkMessage)
module View.Payment.Add
( view
, Input(..)
, In(..)
) where
import Control.Monad (join)
......@@ -17,35 +17,36 @@ import Common.Model (Category (..), CreatePaymentForm (..),
import qualified Common.Msg as Msg
import qualified Common.Util.Time as TimeUtil
import qualified Component.Modal as Modal
import qualified Util.Ajax as Ajax
import qualified Util.Reflex as ReflexUtil
import qualified View.Payment.Form as Form
data Input t = Input
{ _input_categories :: [Category]
, _input_paymentCategories :: Dynamic t [PaymentCategory]
, _input_frequency :: Dynamic t Frequency
data In t = In
{ _in_categories :: [Category]
, _in_paymentCategories :: Dynamic t [PaymentCategory]
, _in_frequency :: Dynamic t Frequency
}
view :: forall t m. MonadWidget t m => Input t -> Modal.Content t m SavedPayment
view :: forall t m. MonadWidget t m => In t -> Modal.Content t m SavedPayment
view input cancel = do
currentDay <- liftIO $ Time.getCurrentTime >>= TimeUtil.timeToDay
formOutput <- R.dyn $ do
paymentCategories <- _input_paymentCategories input
frequency <- _input_frequency input
return $ Form.view $ Form.Input
{ Form._input_cancel = cancel
, Form._input_headerLabel = Msg.get Msg.Payment_Add
, Form._input_categories = _input_categories input
, Form._input_paymentCategories = paymentCategories