TextField.hs

{-|
Module      : Monomer.Widgets.Singles.TextField
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Input field for single line 'Text'. Allows setting the maximum number of
characters and a replacement character for password.

@
textField shortTextLens
@

With configuration options:

@
textField_ shortTextLens [maxLength 100, selectOnFocus_ False]
@

-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Singles.TextField (
  -- * Configuration
  TextFieldCfg,
  textFieldDisplayChar,
  -- * Constructors
  textField,
  textField_,
  textFieldV,
  textFieldV_,
  textFieldD_
) where

import Control.Applicative ((<|>))
import Control.Lens (ALens')
import Data.Default
import Data.Maybe
import Data.Text (Text)

import qualified Data.Text as T

import Monomer.Core
import Monomer.Core.Combinators
import Monomer.Widgets.Singles.Base.InputField

import qualified Monomer.Lens as L

{-|
Configuration options for textField:

- 'validInput': field indicating if the current input is valid. Useful to show
  warnings in the UI, or disable buttons if needed.
- 'resizeOnChange': Whether input causes ResizeWidgets requests.
- 'selectOnFocus': Whether all input should be selected when focus is received.
- 'readOnly': Whether to prevent the user changing the input text.
- 'maxLength': the maximum length of input text.
- 'textFieldDisplayChar': the character that will be displayed as replacement of
  the real text. Useful for password fields.
- 'onFocus': event to raise when focus is received.
- 'onFocusReq': 'WidgetRequest' to generate when focus is received.
- 'onBlur': event to raise when focus is lost.
- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
- 'onChange': event to raise when the value changes.
- 'onChangeReq': 'WidgetRequest' to generate when the value changes.
-}
data TextFieldCfg s e = TextFieldCfg {
  _tfcCaretWidth :: Maybe Double,
  _tfcCaretMs :: Maybe Millisecond,
  _tfcDisplayChar :: Maybe Char,
  _tfcPlaceholder :: Maybe Text,
  _tfcValid :: Maybe (WidgetData s Bool),
  _tfcValidV :: [Bool -> e],
  _tfcMaxLength :: Maybe Int,
  _tfcResizeOnChange :: Maybe Bool,
  _tfcSelectOnFocus :: Maybe Bool,
  _tfcReadOnly :: Maybe Bool,
  _tfcOnFocusReq :: [Path -> WidgetRequest s e],
  _tfcOnBlurReq :: [Path -> WidgetRequest s e],
  _tfcOnChangeReq :: [Text -> WidgetRequest s e]
}

instance Default (TextFieldCfg s e) where
  def = TextFieldCfg {
    _tfcCaretWidth = Nothing,
    _tfcCaretMs = Nothing,
    _tfcDisplayChar = Nothing,
    _tfcPlaceholder = Nothing,
    _tfcValid = Nothing,
    _tfcValidV = [],
    _tfcMaxLength = Nothing,
    _tfcResizeOnChange = Nothing,
    _tfcSelectOnFocus = Nothing,
    _tfcReadOnly = Nothing,
    _tfcOnFocusReq = [],
    _tfcOnBlurReq = [],
    _tfcOnChangeReq = []
  }

instance Semigroup (TextFieldCfg s e) where
  (<>) t1 t2 = TextFieldCfg {
    _tfcCaretWidth = _tfcCaretWidth t2 <|> _tfcCaretWidth t1,
    _tfcCaretMs = _tfcCaretMs t2 <|> _tfcCaretMs t1,
    _tfcDisplayChar = _tfcDisplayChar t2 <|> _tfcDisplayChar t1,
    _tfcPlaceholder = _tfcPlaceholder t2 <|> _tfcPlaceholder t1,
    _tfcValid = _tfcValid t2 <|> _tfcValid t1,
    _tfcValidV = _tfcValidV t1 <> _tfcValidV t2,
    _tfcMaxLength = _tfcMaxLength t2 <|> _tfcMaxLength t1,
    _tfcResizeOnChange = _tfcResizeOnChange t2 <|> _tfcResizeOnChange t1,
    _tfcSelectOnFocus = _tfcSelectOnFocus t2 <|> _tfcSelectOnFocus t1,
    _tfcReadOnly = _tfcReadOnly t2 <|> _tfcReadOnly t1,
    _tfcOnFocusReq = _tfcOnFocusReq t1 <> _tfcOnFocusReq t2,
    _tfcOnBlurReq = _tfcOnBlurReq t1 <> _tfcOnBlurReq t2,
    _tfcOnChangeReq = _tfcOnChangeReq t1 <> _tfcOnChangeReq t2
  }

instance Monoid (TextFieldCfg s e) where
  mempty = def

instance CmbCaretWidth (TextFieldCfg s e) Double where
  caretWidth w = def {
    _tfcCaretWidth = Just w
  }

instance CmbCaretMs (TextFieldCfg s e) Millisecond where
  caretMs ms = def {
    _tfcCaretMs = Just ms
  }

instance CmbPlaceholder (TextFieldCfg s e) Text where
  placeholder value = def {
    _tfcPlaceholder = Just value
  }

instance CmbValidInput (TextFieldCfg s e) s where
  validInput field = def {
    _tfcValid = Just (WidgetLens field)
  }

instance CmbValidInputV (TextFieldCfg s e) e where
  validInputV fn = def {
    _tfcValidV = [fn]
  }

instance CmbResizeOnChange (TextFieldCfg s e) where
  resizeOnChange_ resize = def {
    _tfcResizeOnChange = Just resize
  }

instance CmbSelectOnFocus (TextFieldCfg s e) where
  selectOnFocus_ sel = def {
    _tfcSelectOnFocus = Just sel
  }

instance CmbReadOnly (TextFieldCfg s e) where
  readOnly_ ro = def {
    _tfcReadOnly = Just ro
  }

instance CmbMaxLength (TextFieldCfg s e) where
  maxLength len = def {
    _tfcMaxLength = Just len
  }

instance WidgetEvent e => CmbOnFocus (TextFieldCfg s e) e Path where
  onFocus fn = def {
    _tfcOnFocusReq = [RaiseEvent . fn]
  }

instance CmbOnFocusReq (TextFieldCfg s e) s e Path where
  onFocusReq req = def {
    _tfcOnFocusReq = [req]
  }

instance WidgetEvent e => CmbOnBlur (TextFieldCfg s e) e Path where
  onBlur fn = def {
    _tfcOnBlurReq = [RaiseEvent . fn]
  }

instance CmbOnBlurReq (TextFieldCfg s e) s e Path where
  onBlurReq req = def {
    _tfcOnBlurReq = [req]
  }

instance WidgetEvent e => CmbOnChange (TextFieldCfg s e) Text e where
  onChange fn = def {
    _tfcOnChangeReq = [RaiseEvent . fn]
  }

instance CmbOnChangeReq (TextFieldCfg s e) s e Text where
  onChangeReq req = def {
    _tfcOnChangeReq = [req]
  }

-- | Replacement character to show instead of real text. Useful for passwords.
textFieldDisplayChar :: Char -> TextFieldCfg s e
textFieldDisplayChar char = def {
    _tfcDisplayChar = Just char
  }

-- | Creates a text field using the given lens.
textField :: WidgetEvent e => ALens' s Text -> WidgetNode s e
textField field = textField_ field def

-- | Creates a text field using the given lens. Accepts config.
textField_
  :: WidgetEvent e => ALens' s Text -> [TextFieldCfg s e] -> WidgetNode s e
textField_ field configs = textFieldD_ (WidgetLens field) configs

-- | Creates a text field using the given value and 'onChange' event handler.
textFieldV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e
textFieldV value handler = textFieldV_ value handler def

-- | Creates a text field using the given value and 'onChange' event handler.
--   Accepts config.
textFieldV_
  :: WidgetEvent e => Text -> (Text -> e) -> [TextFieldCfg s e] -> WidgetNode s e
textFieldV_ value handler configs = textFieldD_ widgetData newConfig where
  widgetData = WidgetValue value
  newConfig = onChange handler : configs

-- | Creates a text field providing a 'WidgetData' instance and config.
textFieldD_
  :: WidgetEvent e => WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e
textFieldD_ widgetData configs = inputField where
  config = mconcat configs
  fromText = textToText (_tfcMaxLength config)
  inputConfig = InputFieldCfg {
    _ifcPlaceholder = _tfcPlaceholder config,
    _ifcInitialValue = "",
    _ifcValue = widgetData,
    _ifcValid = _tfcValid config,
    _ifcValidV = _tfcValidV config,
    _ifcFromText = fromText,
    _ifcToText = id,
    _ifcAcceptInput = acceptInput (_tfcMaxLength config),
    _ifcIsValidInput = acceptInput (_tfcMaxLength config),
    _ifcDefCursorEnd = True,
    _ifcDefWidth = 100,
    _ifcCaretWidth = _tfcCaretWidth config,
    _ifcCaretMs = _tfcCaretMs config,
    _ifcDisplayChar = _tfcDisplayChar config,
    _ifcResizeOnChange = fromMaybe False (_tfcResizeOnChange config),
    _ifcSelectOnFocus = fromMaybe False (_tfcSelectOnFocus config),
    _ifcReadOnly = fromMaybe False (_tfcReadOnly config),
    _ifcStyle = Just L.textFieldStyle,
    _ifcWheelHandler = Nothing,
    _ifcDragHandler = Nothing,
    _ifcDragCursor = Nothing,
    _ifcOnFocusReq = _tfcOnFocusReq config,
    _ifcOnBlurReq = _tfcOnBlurReq config,
    _ifcOnChangeReq = _tfcOnChangeReq config
  }
  inputField = inputField_ "textField" inputConfig

textToText :: Maybe Int -> Text -> Maybe Text
textToText Nothing text = Just text
textToText (Just len) text
  | T.length text <= len = Just text
  | otherwise = Nothing

acceptInput :: Maybe Int -> Text -> Bool
acceptInput Nothing _ = True
acceptInput (Just len) text = T.length text <= len