diff options
author | Joris | 2020-01-30 11:35:31 +0000 |
---|---|---|
committer | Joris | 2020-01-30 11:35:31 +0000 |
commit | 960fa7cb7ae4c57d01306f78cd349f3a8337d0ab (patch) | |
tree | 5077cc720525fb025e4dba65a9a8b631862cbcc8 /client/src/Component/Select.hs | |
parent | 14bdbc8c937f5d0b35c61350dba28cb41c3737cd (diff) | |
parent | 6a04e640955051616c3ad0874605830c448f2d75 (diff) | |
download | budget-960fa7cb7ae4c57d01306f78cd349f3a8337d0ab.tar.gz budget-960fa7cb7ae4c57d01306f78cd349f3a8337d0ab.tar.bz2 budget-960fa7cb7ae4c57d01306f78cd349f3a8337d0ab.zip |
Merge branch 'with-ghcjs' into 'master'
Use Haskell on the frontend
See merge request guyonvarch/shared-cost!2
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 + } |