diff options
Diffstat (limited to 'client/src/Component/Select.hs')
-rw-r--r-- | client/src/Component/Select.hs | 80 |
1 files changed, 80 insertions, 0 deletions
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 + } |