Merge branch 'with-ghcjs' into 'master'

Use Haskell on the frontend

See merge request guyonvarch/shared-cost!2

1 files changed, 151 insertions, 0 deletions

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)