aboutsummaryrefslogtreecommitdiff
path: root/client/src/Component/Select.hs
blob: 102f55477ed9dc9b4371edcad91e3c8ef11f2b6d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
module Component.Select
  ( SelectIn(..)
  , SelectOut(..)
  , select
  ) 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) => 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 SelectOut t a = SelectOut
  { _selectOut_raw   :: Dynamic t a
  , _selectOut_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
  rec
    let containerAttr = R.ffor showedError (\e ->
          M.singleton "class" $ T.intercalate " "
            [ "selectInput"
            , if Maybe.isJust e then "error" else ""
            ])

        validatedValue =
          fmap (_selectIn_isValid selectIn) value

        maybeError =
          fmap ValidationUtil.maybeError validatedValue

    showedError <- R.holdDyn Nothing $ R.leftmost
      [ Nothing <$ _selectIn_reset selectIn
      , R.updated maybeError
      , R.attachWith const (R.current maybeError) (_selectIn_validate selectIn)
      ]

    value <- R.elDynAttr "div" containerAttr $ do
      let initialValue = _selectIn_initialValue selectIn

      let setValue = R.leftmost
            [ initialValue <$ (_selectIn_reset selectIn)
            , _selectIn_value selectIn
            ]

      value <- R.el "label" $ do
        R.divClass "label" $
          R.text (_selectIn_label selectIn)

        R._dropdown_value <$>
          R.dropdown
            initialValue
            (_selectIn_values selectIn)
            (R.def { R._dropdownConfig_setValue = setValue })

      R.divClass "errorMessage" . R.dynText $
        R.ffor showedError (Maybe.fromMaybe "")

      return value

  return SelectOut
    { _selectOut_raw = value
    , _selectOut_value = validatedValue
    }