aboutsummaryrefslogtreecommitdiff
path: root/client/src/Component
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Component')
-rw-r--r--client/src/Component/Button.hs56
-rw-r--r--client/src/Component/Form.hs6
-rw-r--r--client/src/Component/Input.hs79
-rw-r--r--client/src/Component/Link.hs6
-rw-r--r--client/src/Component/Modal.hs14
-rw-r--r--client/src/Component/ModalForm.hs61
-rw-r--r--client/src/Component/Pages.hs45
-rw-r--r--client/src/Component/Select.hs56
-rw-r--r--client/src/Component/Table.hs45
9 files changed, 182 insertions, 186 deletions
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
index b1175d7..6faecef 100644
--- a/client/src/Component/Button.hs
+++ b/client/src/Component/Button.hs
@@ -1,8 +1,8 @@
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
}
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
index 6ea02fa..6878e68 100644
--- a/client/src/Component/Form.hs
+++ b/client/src/Component/Form.hs
@@ -1,12 +1,12 @@
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
diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs
index 9ab4d58..37020da 100644
--- a/client/src/Component/Input.hs
+++ b/client/src/Component/Input.hs
@@ -1,8 +1,8 @@
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
diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs
index 7e8558b..1fd620e 100644
--- a/client/src/Component/Link.hs
+++ b/client/src/Component/Link.hs
@@ -1,5 +1,5 @@
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
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
index 96c2679..50af469 100644
--- a/client/src/Component/Modal.hs
+++ b/client/src/Component/Modal.hs
@@ -1,5 +1,5 @@
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))
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
index 63cb1d2..ea53beb 100644
--- a/client/src/Component/ModalForm.hs
+++ b/client/src/Component/ModalForm.hs
@@ -1,7 +1,7 @@
module Component.ModalForm
- ( modalForm
- , ModalFormIn(..)
- , ModalFormOut(..)
+ ( view
+ , In(..)
+ , Out(..)
) where
import Data.Aeson (ToJSON)
@@ -14,57 +14,56 @@ import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Common.Msg as Msg
-import Component.Button (ButtonIn (..))
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 ModalFormIn m t a b e = ModalFormIn
- { _modalFormIn_headerLabel :: Text
- , _modalFormIn_form :: m (Dynamic t (Validation e a))
- , _modalFormIn_ajax :: Event t a -> m (Event t (Either Text b))
+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 ModalFormOut t a = ModalFormOut
- { _modalFormOut_hide :: Event t ()
- , _modalFormOut_cancel :: Event t ()
- , _modalFormOut_confirm :: Event t ()
- , _modalFormOut_validate :: Event t a
+data Out t a = Out
+ { _out_hide :: Event t ()
+ , _out_cancel :: Event t ()
+ , _out_confirm :: Event t ()
+ , _out_validate :: Event t a
}
-modalForm :: forall t m a b e. (MonadWidget t m, ToJSON a) => ModalFormIn m t a b e -> m (ModalFormOut t b)
-modalForm modalFormIn =
+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 (_modalFormIn_headerLabel modalFormIn)
+ R.text (_in_headerLabel input)
R.divClass "formContent" $ do
rec
- form <- _modalFormIn_form modalFormIn
+ form <- _in_form input
(validate, cancel, confirm) <- R.divClass "buttons" $ do
rec
- cancel <- Button._buttonOut_clic <$> (Button.button $
- (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Undo))
- { _buttonIn_class = R.constDyn "undo" })
+ cancel <- Button._out_clic <$> (Button.view $
+ (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+ { Button._in_class = R.constDyn "undo" })
- confirm <- Button._buttonOut_clic <$> (Button.button $
- (Button.defaultButtonIn (R.text $ Msg.get Msg.Dialog_Confirm))
- { _buttonIn_class = R.constDyn "confirm"
- , _buttonIn_waiting = waiting
- , _buttonIn_submit = True
+ 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
- (_modalFormIn_ajax modalFormIn)
+ (_in_ajax input)
(ValidationUtil.fireValidation form confirm)
return (R.fmapMaybe EitherUtil.eitherToMaybe validate, cancel, confirm)
- return ModalFormOut
- { _modalFormOut_hide = R.leftmost [ cancel, () <$ validate ]
- , _modalFormOut_cancel = cancel
- , _modalFormOut_confirm = confirm
- , _modalFormOut_validate = validate
+ return Out
+ { _out_hide = R.leftmost [ cancel, () <$ validate ]
+ , _out_cancel = cancel
+ , _out_confirm = confirm
+ , _out_validate = validate
}
diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
index 7843ef6..7284a36 100644
--- a/client/src/Component/Pages.hs
+++ b/client/src/Component/Pages.hs
@@ -1,41 +1,40 @@
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
diff --git a/client/src/Component/Select.hs b/client/src/Component/Select.hs
index 102f554..375ae06 100644
--- a/client/src/Component/Select.hs
+++ b/client/src/Component/Select.hs
@@ -1,7 +1,7 @@
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
}
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
index b431c14..bf76566 100644
--- a/client/src/Component/Table.hs
+++ b/client/src/Component/Table.hs
@@ -1,29 +1,28 @@
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 Component.Pages (PagesIn (..), PagesOut (..))
import qualified Component.Pages as Pages
-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 h r t = In
+ { _in_headerLabel :: h -> Text
+ , _in_rows :: Dynamic t [r]
+ , _in_cell :: h -> r -> Text
+ , _in_perPage :: Int
+ , _in_resetPage :: Event t ()
}
-data TableOut = TableOut
+data Out = Out
{}
-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. (MonadWidget t m, Bounded h, Enum h) => In h r t -> m (Out)
+view input =
R.divClass "table" $ do
rec
R.divClass "lines" $ do
@@ -31,29 +30,29 @@ table tableIn =
R.divClass "header" $
flip mapM_ [minBound..] $ \header ->
R.divClass "cell" . R.text $
- _tableIn_headerLabel tableIn header
+ _in_headerLabel input header
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" $
flip mapM_ [minBound..] $ \h ->
R.divClass "cell name" $
R.dynText $
- R.ffor r (_tableIn_cell tableIn h)
+ R.ffor r (_in_cell input h)
- 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 $ TableOut
+ return $ Out
{}
getRange :: forall a. Int -> Int -> [a] -> [a]