aboutsummaryrefslogtreecommitdiff
path: root/client/src/Component
diff options
context:
space:
mode:
Diffstat (limited to 'client/src/Component')
-rw-r--r--client/src/Component/Appearing.hs10
-rw-r--r--client/src/Component/Button.hs57
-rw-r--r--client/src/Component/ConfirmDialog.hs49
-rw-r--r--client/src/Component/Form.hs12
-rw-r--r--client/src/Component/Input.hs151
-rw-r--r--client/src/Component/Link.hs33
-rw-r--r--client/src/Component/Modal.hs117
-rw-r--r--client/src/Component/ModalForm.hs71
-rw-r--r--client/src/Component/Pages.hs86
-rw-r--r--client/src/Component/Select.hs80
-rw-r--r--client/src/Component/Table.hs105
-rw-r--r--client/src/Component/Tag.hs27
12 files changed, 798 insertions, 0 deletions
diff --git a/client/src/Component/Appearing.hs b/client/src/Component/Appearing.hs
new file mode 100644
index 0000000..e0144ca
--- /dev/null
+++ b/client/src/Component/Appearing.hs
@@ -0,0 +1,10 @@
+module Component.Appearing
+ ( view
+ ) where
+
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+view :: forall t m a. MonadWidget t m => m a -> m a
+view =
+ R.divClass "g-Appearing"
diff --git a/client/src/Component/Button.hs b/client/src/Component/Button.hs
new file mode 100644
index 0000000..153a61b
--- /dev/null
+++ b/client/src/Component/Button.hs
@@ -0,0 +1,57 @@
+module Component.Button
+ ( In(..)
+ , Out(..)
+ , view
+ , defaultIn
+ ) where
+
+import qualified Data.Map as M
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified View.Icon as Icon
+
+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
+ }
+
+defaultIn :: forall t m. 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 Out t = Out
+ { _out_clic :: Event t ()
+ }
+
+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 <- _in_class input
+ waiting <- dynWaiting
+ return . M.fromList . catMaybes $
+ [ 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" $ _in_content input
+
+ return $ Out
+ { _out_clic = R.domEvent R.Click e
+ }
diff --git a/client/src/Component/ConfirmDialog.hs b/client/src/Component/ConfirmDialog.hs
new file mode 100644
index 0000000..cf26593
--- /dev/null
+++ b/client/src/Component/ConfirmDialog.hs
@@ -0,0 +1,49 @@
+module Component.ConfirmDialog
+ ( In(..)
+ , view
+ ) where
+
+import Data.Text (Text)
+import Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Common.Msg as Msg
+import qualified Component.Button as Button
+import qualified Component.Modal as Modal
+import qualified Util.Either as EitherUtil
+import qualified Util.WaitFor as WaitFor
+
+data In t m = In
+ { _in_header :: Text
+ , _in_confirm :: Event t () -> m (Event t ())
+ }
+
+view :: forall t m a. MonadWidget t m => (In t m) -> Modal.Content t m
+view input _ =
+ R.divClass "confirm" $ do
+ R.divClass "confirmHeader" $
+ R.text $ _in_header input
+
+ R.divClass "confirmContent" $ do
+ (confirm, cancel) <- R.divClass "buttons" $ do
+
+ cancel <- Button._out_clic <$> (Button.view $
+ (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Undo))
+ { Button._in_class = R.constDyn "undo" })
+
+ rec
+ confirm <- Button._out_clic <$> (Button.view $
+ (Button.defaultIn (R.text $ Msg.get Msg.Dialog_Confirm))
+ { Button._in_class = R.constDyn "confirm"
+ , Button._in_submit = True
+ , Button._in_waiting = waiting
+ })
+
+ (result, waiting) <- WaitFor.waitFor (_in_confirm input) confirm
+
+ return (result, cancel)
+
+ return $
+ ( R.leftmost [ cancel, () <$ confirm ]
+ , confirm
+ )
diff --git a/client/src/Component/Form.hs b/client/src/Component/Form.hs
new file mode 100644
index 0000000..6878e68
--- /dev/null
+++ b/client/src/Component/Form.hs
@@ -0,0 +1,12 @@
+module Component.Form
+ ( view
+ ) where
+
+import qualified Data.Map as M
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+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
new file mode 100644
index 0000000..bcff377
--- /dev/null
+++ b/client/src/Component/Input.hs
@@ -0,0 +1,151 @@
+module Component.Input
+ ( In(..)
+ , Out(..)
+ , view
+ , defaultIn
+ ) where
+
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (NominalDiffTime)
+import Data.Validation (Validation (Failure, Success))
+import qualified Data.Validation as V
+import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex,
+ (&), (.~))
+import qualified Reflex.Dom as R
+
+import qualified Common.Util.Validation as ValidationUtil
+import qualified Component.Button as Button
+import qualified View.Icon as Icon
+
+data In a = In
+ { _in_hasResetButton :: Bool
+ , _in_label :: Text
+ , _in_initialValue :: Text
+ , _in_inputType :: Text
+ , _in_validation :: Text -> Validation Text a
+ }
+
+defaultIn :: In Text
+defaultIn = In
+ { _in_hasResetButton = True
+ , _in_label = ""
+ , _in_initialValue = ""
+ , _in_inputType = "text"
+ , _in_validation = V.Success
+ }
+
+data Out t a = Out
+ { _out_raw :: Dynamic t Text
+ , _out_value :: Dynamic t (Validation Text a)
+ , _out_enter :: Event t ()
+ }
+
+view
+ :: forall t m a b. MonadWidget t m
+ => In a
+ -> Event t Text -- reset
+ -> Event t b -- validate
+ -> m (Out t a)
+view input reset validate = do
+ rec
+ let resetValue = R.leftmost
+ [ reset
+ , fmap (const "") resetClic
+ ]
+
+ inputAttr = R.ffor value (\v ->
+ if T.null v && _in_inputType input /= "date" && _in_inputType input /= "color"
+ then M.empty
+ else M.singleton "class" "filled")
+
+ value = R._textInput_value textInput
+
+ containerAttr = R.ffor inputError (\e ->
+ M.singleton "class" $ T.intercalate " "
+ [ "textInput"
+ , if Maybe.isJust e then "error" else ""
+ ])
+
+ let valueWithValidation = R.ffor value (\v -> (v, _in_validation input $ v))
+ inputError <- getInputError valueWithValidation validate
+
+ (textInput, resetClic) <- R.elDynAttr "div" containerAttr $ do
+
+ textInput <- R.el "label" $ do
+ textInput <- R.textInput $ R.def
+ & R.attributes .~ inputAttr
+ & R.setValue .~ resetValue
+ & R.textInputConfig_initialValue .~ (_in_initialValue input)
+ & R.textInputConfig_inputType .~ (_in_inputType input)
+
+ R.divClass "label" $
+ R.text (_in_label input)
+
+ return textInput
+
+ resetClic <-
+ if _in_hasResetButton input
+ then
+ Button._out_clic <$> (Button.view $
+ (Button.defaultIn Icon.cross)
+ { Button._in_class = R.constDyn "reset"
+ , Button._in_tabIndex = Just (-1)
+ })
+ else
+ return R.never
+
+ R.divClass "errorMessage" $
+ R.dynText . fmap (Maybe.fromMaybe "") $ inputError
+
+ return (textInput, resetClic)
+
+ let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput
+
+ return $ Out
+ { _out_raw = value
+ , _out_value = fmap snd valueWithValidation
+ , _out_enter = enter
+ }
+
+getInputError
+ :: forall t m a b c. MonadWidget t m
+ => Dynamic t (Text, Validation Text a)
+ -> Event t c
+ -> m (Dynamic t (Maybe Text))
+getInputError validatedValue validate = do
+ let errorDynamic = fmap (\(t, v) -> (t, validationError v)) validatedValue
+ errorEvent = R.updated errorDynamic
+ delayedError <- R.debounce (1 :: NominalDiffTime) errorEvent
+ fmap (fmap fst) $ R.foldDyn
+ (\event (err, hasBeenResetted) ->
+ case event of
+ ModifiedEvent t ->
+ (Nothing, T.null t)
+
+ ValidateEvent e ->
+ (e, False)
+
+ DelayEvent e ->
+ if hasBeenResetted then
+ (Nothing, False)
+ else
+ (e, False)
+ )
+ (Nothing, False)
+ (R.leftmost
+ [ fmap (\(t, _) -> ModifiedEvent t) errorEvent
+ , fmap (\(_, e) -> DelayEvent e) delayedError
+ , R.attachWith (\(_, e) _ -> ValidateEvent e) (R.current errorDynamic) validate
+ ])
+
+validationError :: (Validation Text a) -> Maybe Text
+validationError (Failure e) = Just e
+validationError _ = Nothing
+
+data InputEvent
+ = ModifiedEvent Text
+ | DelayEvent (Maybe Text)
+ | ValidateEvent (Maybe Text)
diff --git a/client/src/Component/Link.hs b/client/src/Component/Link.hs
new file mode 100644
index 0000000..1fd620e
--- /dev/null
+++ b/client/src/Component/Link.hs
@@ -0,0 +1,33 @@
+module Component.Link
+ ( view
+ ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, MonadWidget)
+import qualified Reflex.Dom as R
+
+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
+
+ onclickHandler =
+ T.intercalate ";"
+ [ "history.pushState(0, '', event.target.href)"
+ , "dispatchEvent(new PopStateEvent('popstate', {cancelable: true, bubbles: true, view: window}))"
+ , "return false"
+ ]
+
+ attrs =
+ R.ffor inputAttrs (\as ->
+ (M.union
+ (M.fromList
+ [ ("onclick", onclickHandler)
+ , ("href", href)
+ ]
+ )
+ as)
+ )
diff --git a/client/src/Component/Modal.hs b/client/src/Component/Modal.hs
new file mode 100644
index 0000000..46d3f64
--- /dev/null
+++ b/client/src/Component/Modal.hs
@@ -0,0 +1,117 @@
+module Component.Modal
+ ( In(..)
+ , Content
+ , view
+ ) where
+
+import Control.Monad (void)
+import qualified Data.Map as M
+import qualified Data.Map.Lazy as LM
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (NominalDiffTime)
+import qualified GHCJS.DOM.Element as Element
+import qualified GHCJS.DOM.Node as Node
+import JSDOM.Types (JSString)
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+import qualified Reflex.Dom.Class as R
+
+import qualified Util.Reflex as ReflexUtil
+
+-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
+type Content t m = Event t () -> m (Event t (), Event t ())
+
+data In t m = In
+ { _in_show :: Event t ()
+ , _in_content :: Content t m
+ }
+
+view :: forall t m a. MonadWidget t m => In t m -> m (Event t ())
+view input = do
+ rec
+ let show = Show <$ (_in_show input)
+
+ startHiding =
+ R.attachWithMaybe
+ (\a _ -> if a then Just StartHiding else Nothing)
+ (R.current canBeHidden)
+ (R.leftmost [ hide, curtainClick ])
+
+ canBeHidden <-
+ R.holdDyn True $ R.leftmost
+ [ False <$ startHiding
+ , True <$ endHiding
+ ]
+
+ endHiding <-
+ R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding)
+
+ let action =
+ R.leftmost [ show, startHiding, endHiding ]
+
+ modalClass <-
+ R.holdDyn "" (fmap getModalClass action)
+
+ (elem, dyn) <-
+ R.buildElement "div" (getAttributes <$> modalClass) $
+ ReflexUtil.visibleIfEvent
+ (isVisible <$> action)
+ (R.blank >> return (R.never, R.never, R.never))
+ (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" (_in_content input curtainClick)
+ return (curtainClick, hide, content))
+
+
+ performShowEffects action elem
+
+ let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn
+ let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn
+ let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
+
+ -- Delay the event in order to let time for the modal to disappear
+ R.delay (0.5 :: NominalDiffTime) content
+
+getAttributes :: Text -> LM.Map Text Text
+getAttributes modalClass =
+ M.singleton "class" $
+ T.intercalate " " [ "g-Modal", modalClass]
+
+performShowEffects
+ :: forall t m a. MonadWidget t m
+ => Event t Action
+ -> Element.Element
+ -> m ()
+performShowEffects showEvent elem = do
+ body <- ReflexUtil.getBody
+
+ let showEffects =
+ flip fmap showEvent (\case
+ Show -> do
+ Node.appendChild body elem
+ Element.setClassName body ("g-Body--Modal" :: JSString)
+ StartHiding ->
+ return ()
+ EndHiding -> do
+ Node.removeChild body elem
+ Element.setClassName body ("" :: JSString)
+ )
+
+ R.performEvent_ $ void `fmap` showEffects
+
+data Action
+ = Show
+ | StartHiding
+ | EndHiding
+
+getModalClass :: Action -> Text
+getModalClass Show = "g-Modal--Show"
+getModalClass StartHiding = "g-Modal--Hiding"
+getModalClass _ = ""
+
+isVisible :: Action -> Bool
+isVisible Show = True
+isVisible StartHiding = True
+isVisible EndHiding = False
diff --git a/client/src/Component/ModalForm.hs b/client/src/Component/ModalForm.hs
new file mode 100644
index 0000000..c56ff88
--- /dev/null
+++ b/client/src/Component/ModalForm.hs
@@ -0,0 +1,71 @@
+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 Component.Form as Form
+import qualified Util.Either as EitherUtil
+import qualified Util.Validation as ValidationUtil
+import qualified Util.WaitFor as WaitFor
+
+data In m t a e = In
+ { _in_headerLabel :: Text
+ , _in_form :: m (Dynamic t (Validation e a))
+ , _in_ajax :: Event t a -> m (Event t (Either Text ()))
+ }
+
+data Out t = Out
+ { _out_hide :: Event t ()
+ , _out_cancel :: Event t ()
+ , _out_confirm :: Event t ()
+ , _out_validate :: Event t ()
+ }
+
+view :: forall t m a e. (MonadWidget t m, ToJSON a) => In m t a e -> m (Out t)
+view input =
+ R.divClass "form" $ do
+ R.divClass "formHeader" $
+ R.text (_in_headerLabel input)
+
+ Form.view $
+ 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
+ }
diff --git a/client/src/Component/Pages.hs b/client/src/Component/Pages.hs
new file mode 100644
index 0000000..d54cd3d
--- /dev/null
+++ b/client/src/Component/Pages.hs
@@ -0,0 +1,86 @@
+module Component.Pages
+ ( view
+ , In(..)
+ , Out(..)
+ ) where
+
+import qualified Data.Text as T
+import Reflex.Dom (Dynamic, Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Component.Button as Button
+
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Icon as Icon
+
+data In t = In
+ { _in_total :: Dynamic t Int
+ , _in_perPage :: Int
+ , _in_page :: Int
+ }
+
+data Out t = Out
+ { _out_newPage :: Event t Int
+ }
+
+view :: forall t m. MonadWidget t m => In t -> m (Out t)
+view input = do
+ newPage <- ReflexUtil.divVisibleIf ((> 0) <$> (_in_total input)) $ pageButtons input
+
+ return $ Out
+ { _out_newPage = newPage
+ }
+
+pageButtons
+ :: forall t m. MonadWidget t m
+ => In t
+ -> m (Event t Int)
+pageButtons input = do
+ R.divClass "pages" $ do
+ rec
+ let newPage = R.leftmost
+ [ firstPageClic
+ , previousPageClic
+ , pageClic
+ , nextPageClic
+ , lastPageClic
+ ]
+
+ currentPage <- R.holdDyn (_in_page input) newPage
+
+ firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar
+
+ previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft
+
+ pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p ->
+ pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p))
+
+ nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight
+
+ lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar
+
+ return newPage
+
+ where maxPage = R.ffor (_in_total input) (\t -> ceiling $ toRational t / toRational (_in_perPage input))
+ pageEvent = R.switch . R.current . fmap R.leftmost
+ noCurrentPage = R.constDyn Nothing
+
+range :: Int -> Int -> [Int]
+range currentPage maxPage = [start..end]
+ where sidePages = 2
+ start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2))
+ end = min maxPage (start + sidePages * 2)
+
+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 <- Button._out_clic <$> (Button.view $ Button.In
+ { Button._in_class = do
+ cp <- currentPage
+ p <- page
+ if cp == Just p then "page current" else "page"
+ , 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
new file mode 100644
index 0000000..70f5f58
--- /dev/null
+++ b/client/src/Component/Select.hs
@@ -0,0 +1,80 @@
+module Component.Select
+ ( view
+ , In(..)
+ , Out(..)
+ ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import qualified Data.Maybe as Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Validation (Validation)
+import Reflex.Dom (Dynamic, Event, MonadWidget, Reflex)
+import qualified Reflex.Dom as R
+
+import qualified Util.Validation as ValidationUtil
+
+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 Out t a = Out
+ { _out_raw :: Dynamic t a
+ , _out_value :: Dynamic t (Validation Text a)
+ }
+
+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 " "
+ [ "input selectInput"
+ , if Maybe.isJust e then "error" else ""
+ ])
+
+ validatedValue =
+ fmap (_in_isValid input) value
+
+ maybeError =
+ fmap ValidationUtil.maybeError validatedValue
+
+ showedError <- R.holdDyn Nothing $ R.leftmost
+ [ Nothing <$ _in_reset input
+ , R.updated maybeError
+ , R.attachWith const (R.current maybeError) (_in_validate input)
+ ]
+
+ value <- R.elDynAttr "div" containerAttr $ do
+ let initialValue = _in_initialValue input
+
+ let setValue = R.leftmost
+ [ initialValue <$ (_in_reset input)
+ , _in_value input
+ ]
+
+ value <- R.el "label" $ do
+ R.divClass "label" $
+ R.text (_in_label input)
+
+ R._dropdown_value <$>
+ R.dropdown
+ initialValue
+ (_in_values input)
+ (R.def { R._dropdownConfig_setValue = setValue })
+
+ R.divClass "errorMessage" . R.dynText $
+ R.ffor showedError (Maybe.fromMaybe "")
+
+ return value
+
+ return Out
+ { _out_raw = value
+ , _out_value = validatedValue
+ }
diff --git a/client/src/Component/Table.hs b/client/src/Component/Table.hs
new file mode 100644
index 0000000..1482f91
--- /dev/null
+++ b/client/src/Component/Table.hs
@@ -0,0 +1,105 @@
+module Component.Table
+ ( view
+ , In(..)
+ , Out(..)
+ ) where
+
+import qualified Data.Map as M
+import Data.Text (Text)
+import Reflex.Dom (Event, MonadWidget)
+import qualified Reflex.Dom as R
+
+import qualified Component.Button as Button
+import qualified Component.Modal as Modal
+import qualified Util.Reflex as ReflexUtil
+import qualified View.Icon as Icon
+
+data In m t h r = In
+ { _in_headerLabel :: h -> Text
+ , _in_rows :: [r]
+ , _in_cell :: h -> r -> m ()
+ , _in_cloneModal :: r -> Modal.Content t m
+ , _in_editModal :: r -> Modal.Content t m
+ , _in_deleteModal :: r -> Modal.Content t m
+ , _in_canEdit :: r -> Bool
+ , _in_canDelete :: r -> Bool
+ }
+
+data Out t = Out
+ { _out_add :: Event t ()
+ , _out_edit :: Event t ()
+ , _out_delete :: Event t ()
+ }
+
+view :: forall t m h r. (MonadWidget t m, Bounded h, Enum h) => In m t h r -> m (Out t)
+view input =
+ R.divClass "table" $ do
+ rec
+ result <- R.divClass "lines" $ do
+
+ R.divClass "header" $ do
+ flip mapM_ [minBound..] $ \header ->
+ R.divClass "cell" . R.text $
+ _in_headerLabel input header
+
+ R.divClass "cell" $ R.blank
+ R.divClass "cell" $ R.blank
+ R.divClass "cell" $ R.blank
+
+ flip mapM (_in_rows input) $ \row ->
+ R.divClass "row" $ do
+ flip mapM_ [minBound..] $ \header ->
+ R.divClass "cell" $
+ _in_cell input header row
+
+ cloneButton <-
+ R.divClass "cell button" $
+ Button._out_clic <$> (Button.view $
+ Button.defaultIn Icon.clone)
+
+ clone <-
+ Modal.view $ Modal.In
+ { Modal._in_show = cloneButton
+ , Modal._in_content = _in_cloneModal input row
+ }
+
+ let visibleIf cond =
+ R.elAttr
+ "div"
+ (if cond then M.empty else M.singleton "style" "display:none")
+
+ editButton <-
+ R.divClass "cell button" $
+ visibleIf (_in_canEdit input row) $
+ Button._out_clic <$> (Button.view $
+ Button.defaultIn Icon.edit)
+
+ edit <-
+ Modal.view $ Modal.In
+ { Modal._in_show = editButton
+ , Modal._in_content = _in_editModal input row
+ }
+
+ deleteButton <-
+ R.divClass "cell button" $
+ visibleIf (_in_canDelete input row) $
+ Button._out_clic <$> (Button.view $
+ Button.defaultIn Icon.delete)
+
+ delete <-
+ Modal.view $ Modal.In
+ { Modal._in_show = deleteButton
+ , Modal._in_content = _in_deleteModal input row
+ }
+
+ return (clone, edit, delete)
+
+ let add = R.leftmost . map (\(a, _, _) -> a) $ result
+ edit = R.leftmost . map (\(_, a, _) -> a) $ result
+ delete = R.leftmost . map (\(_, _, a) -> a) $ result
+
+ return $ Out
+ { _out_add = add
+ , _out_edit = edit
+ , _out_delete = delete
+ }
diff --git a/client/src/Component/Tag.hs b/client/src/Component/Tag.hs
new file mode 100644
index 0000000..f75b8d3
--- /dev/null
+++ b/client/src/Component/Tag.hs
@@ -0,0 +1,27 @@
+module Component.Tag
+ ( In(..)
+ , view
+ ) where
+
+import qualified Data.Map as M
+import Data.Text (Text)
+import qualified Data.Text as T
+import Reflex.Dom (MonadWidget)
+import qualified Reflex.Dom as R
+
+data In = In
+ { _in_text :: Text
+ , _in_color :: Text
+ }
+
+view :: forall t m a. MonadWidget t m => In -> m ()
+view input =
+ R.elAttr "span" attrs $
+ R.text $ _in_text input
+
+ where
+ attrs =
+ M.fromList
+ [ ("class", "tag")
+ , ("style", T.concat [ "background-color: ", _in_color input ])
+ ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 11:16:02 +0000