diff options
Diffstat (limited to 'client/src/Component')
-rw-r--r-- | client/src/Component/Button.hs | 56 | ||||
-rw-r--r-- | client/src/Component/Form.hs | 6 | ||||
-rw-r--r-- | client/src/Component/Input.hs | 79 | ||||
-rw-r--r-- | client/src/Component/Link.hs | 6 | ||||
-rw-r--r-- | client/src/Component/Modal.hs | 14 | ||||
-rw-r--r-- | client/src/Component/ModalForm.hs | 61 | ||||
-rw-r--r-- | client/src/Component/Pages.hs | 45 | ||||
-rw-r--r-- | client/src/Component/Select.hs | 56 | ||||
-rw-r--r-- | client/src/Component/Table.hs | 45 |
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] |