{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Strict #-}
module Monomer.Widgets.Singles.TextField (
TextFieldCfg,
textFieldDisplayChar,
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
data TextFieldCfg s e = TextFieldCfg {
forall s e. TextFieldCfg s e -> Maybe Double
_tfcCaretWidth :: Maybe Double,
forall s e. TextFieldCfg s e -> Maybe Millisecond
_tfcCaretMs :: Maybe Millisecond,
forall s e. TextFieldCfg s e -> Maybe Char
_tfcDisplayChar :: Maybe Char,
forall s e. TextFieldCfg s e -> Maybe Text
_tfcPlaceholder :: Maybe Text,
forall s e. TextFieldCfg s e -> Maybe (WidgetData s Bool)
_tfcValid :: Maybe (WidgetData s Bool),
forall s e. TextFieldCfg s e -> [Bool -> e]
_tfcValidV :: [Bool -> e],
forall s e. TextFieldCfg s e -> Maybe Int
_tfcMaxLength :: Maybe Int,
forall s e. TextFieldCfg s e -> Maybe Bool
_tfcResizeOnChange :: Maybe Bool,
forall s e. TextFieldCfg s e -> Maybe Bool
_tfcSelectOnFocus :: Maybe Bool,
forall s e. TextFieldCfg s e -> Maybe Bool
_tfcReadOnly :: Maybe Bool,
forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnFocusReq :: [Path -> WidgetRequest s e],
forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnBlurReq :: [Path -> WidgetRequest s e],
forall s e. TextFieldCfg s e -> [Text -> WidgetRequest s e]
_tfcOnChangeReq :: [Text -> WidgetRequest s e]
}
instance Default (TextFieldCfg s e) where
def :: TextFieldCfg s e
def = TextFieldCfg {
_tfcCaretWidth :: Maybe Double
_tfcCaretWidth = forall a. Maybe a
Nothing,
_tfcCaretMs :: Maybe Millisecond
_tfcCaretMs = forall a. Maybe a
Nothing,
_tfcDisplayChar :: Maybe Char
_tfcDisplayChar = forall a. Maybe a
Nothing,
_tfcPlaceholder :: Maybe Text
_tfcPlaceholder = forall a. Maybe a
Nothing,
_tfcValid :: Maybe (WidgetData s Bool)
_tfcValid = forall a. Maybe a
Nothing,
_tfcValidV :: [Bool -> e]
_tfcValidV = [],
_tfcMaxLength :: Maybe Int
_tfcMaxLength = forall a. Maybe a
Nothing,
_tfcResizeOnChange :: Maybe Bool
_tfcResizeOnChange = forall a. Maybe a
Nothing,
_tfcSelectOnFocus :: Maybe Bool
_tfcSelectOnFocus = forall a. Maybe a
Nothing,
_tfcReadOnly :: Maybe Bool
_tfcReadOnly = forall a. Maybe a
Nothing,
_tfcOnFocusReq :: [Path -> WidgetRequest s e]
_tfcOnFocusReq = [],
_tfcOnBlurReq :: [Path -> WidgetRequest s e]
_tfcOnBlurReq = [],
_tfcOnChangeReq :: [Text -> WidgetRequest s e]
_tfcOnChangeReq = []
}
instance Semigroup (TextFieldCfg s e) where
<> :: TextFieldCfg s e -> TextFieldCfg s e -> TextFieldCfg s e
(<>) TextFieldCfg s e
t1 TextFieldCfg s e
t2 = TextFieldCfg {
_tfcCaretWidth :: Maybe Double
_tfcCaretWidth = forall s e. TextFieldCfg s e -> Maybe Double
_tfcCaretWidth TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Double
_tfcCaretWidth TextFieldCfg s e
t1,
_tfcCaretMs :: Maybe Millisecond
_tfcCaretMs = forall s e. TextFieldCfg s e -> Maybe Millisecond
_tfcCaretMs TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Millisecond
_tfcCaretMs TextFieldCfg s e
t1,
_tfcDisplayChar :: Maybe Char
_tfcDisplayChar = forall s e. TextFieldCfg s e -> Maybe Char
_tfcDisplayChar TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Char
_tfcDisplayChar TextFieldCfg s e
t1,
_tfcPlaceholder :: Maybe Text
_tfcPlaceholder = forall s e. TextFieldCfg s e -> Maybe Text
_tfcPlaceholder TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Text
_tfcPlaceholder TextFieldCfg s e
t1,
_tfcValid :: Maybe (WidgetData s Bool)
_tfcValid = forall s e. TextFieldCfg s e -> Maybe (WidgetData s Bool)
_tfcValid TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe (WidgetData s Bool)
_tfcValid TextFieldCfg s e
t1,
_tfcValidV :: [Bool -> e]
_tfcValidV = forall s e. TextFieldCfg s e -> [Bool -> e]
_tfcValidV TextFieldCfg s e
t1 forall a. Semigroup a => a -> a -> a
<> forall s e. TextFieldCfg s e -> [Bool -> e]
_tfcValidV TextFieldCfg s e
t2,
_tfcMaxLength :: Maybe Int
_tfcMaxLength = forall s e. TextFieldCfg s e -> Maybe Int
_tfcMaxLength TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Int
_tfcMaxLength TextFieldCfg s e
t1,
_tfcResizeOnChange :: Maybe Bool
_tfcResizeOnChange = forall s e. TextFieldCfg s e -> Maybe Bool
_tfcResizeOnChange TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Bool
_tfcResizeOnChange TextFieldCfg s e
t1,
_tfcSelectOnFocus :: Maybe Bool
_tfcSelectOnFocus = forall s e. TextFieldCfg s e -> Maybe Bool
_tfcSelectOnFocus TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Bool
_tfcSelectOnFocus TextFieldCfg s e
t1,
_tfcReadOnly :: Maybe Bool
_tfcReadOnly = forall s e. TextFieldCfg s e -> Maybe Bool
_tfcReadOnly TextFieldCfg s e
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall s e. TextFieldCfg s e -> Maybe Bool
_tfcReadOnly TextFieldCfg s e
t1,
_tfcOnFocusReq :: [Path -> WidgetRequest s e]
_tfcOnFocusReq = forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnFocusReq TextFieldCfg s e
t1 forall a. Semigroup a => a -> a -> a
<> forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnFocusReq TextFieldCfg s e
t2,
_tfcOnBlurReq :: [Path -> WidgetRequest s e]
_tfcOnBlurReq = forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnBlurReq TextFieldCfg s e
t1 forall a. Semigroup a => a -> a -> a
<> forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnBlurReq TextFieldCfg s e
t2,
_tfcOnChangeReq :: [Text -> WidgetRequest s e]
_tfcOnChangeReq = forall s e. TextFieldCfg s e -> [Text -> WidgetRequest s e]
_tfcOnChangeReq TextFieldCfg s e
t1 forall a. Semigroup a => a -> a -> a
<> forall s e. TextFieldCfg s e -> [Text -> WidgetRequest s e]
_tfcOnChangeReq TextFieldCfg s e
t2
}
instance Monoid (TextFieldCfg s e) where
mempty :: TextFieldCfg s e
mempty = forall a. Default a => a
def
instance CmbCaretWidth (TextFieldCfg s e) Double where
caretWidth :: Double -> TextFieldCfg s e
caretWidth Double
w = forall a. Default a => a
def {
_tfcCaretWidth :: Maybe Double
_tfcCaretWidth = forall a. a -> Maybe a
Just Double
w
}
instance CmbCaretMs (TextFieldCfg s e) Millisecond where
caretMs :: Millisecond -> TextFieldCfg s e
caretMs Millisecond
ms = forall a. Default a => a
def {
_tfcCaretMs :: Maybe Millisecond
_tfcCaretMs = forall a. a -> Maybe a
Just Millisecond
ms
}
instance CmbPlaceholder (TextFieldCfg s e) Text where
placeholder :: Text -> TextFieldCfg s e
placeholder Text
value = forall a. Default a => a
def {
_tfcPlaceholder :: Maybe Text
_tfcPlaceholder = forall a. a -> Maybe a
Just Text
value
}
instance CmbValidInput (TextFieldCfg s e) s where
validInput :: ALens' s Bool -> TextFieldCfg s e
validInput ALens' s Bool
field = forall a. Default a => a
def {
_tfcValid :: Maybe (WidgetData s Bool)
_tfcValid = forall a. a -> Maybe a
Just (forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s Bool
field)
}
instance CmbValidInputV (TextFieldCfg s e) e where
validInputV :: (Bool -> e) -> TextFieldCfg s e
validInputV Bool -> e
fn = forall a. Default a => a
def {
_tfcValidV :: [Bool -> e]
_tfcValidV = [Bool -> e
fn]
}
instance CmbResizeOnChange (TextFieldCfg s e) where
resizeOnChange_ :: Bool -> TextFieldCfg s e
resizeOnChange_ Bool
resize = forall a. Default a => a
def {
_tfcResizeOnChange :: Maybe Bool
_tfcResizeOnChange = forall a. a -> Maybe a
Just Bool
resize
}
instance CmbSelectOnFocus (TextFieldCfg s e) where
selectOnFocus_ :: Bool -> TextFieldCfg s e
selectOnFocus_ Bool
sel = forall a. Default a => a
def {
_tfcSelectOnFocus :: Maybe Bool
_tfcSelectOnFocus = forall a. a -> Maybe a
Just Bool
sel
}
instance CmbReadOnly (TextFieldCfg s e) where
readOnly_ :: Bool -> TextFieldCfg s e
readOnly_ Bool
ro = forall a. Default a => a
def {
_tfcReadOnly :: Maybe Bool
_tfcReadOnly = forall a. a -> Maybe a
Just Bool
ro
}
instance CmbMaxLength (TextFieldCfg s e) where
maxLength :: Int -> TextFieldCfg s e
maxLength Int
len = forall a. Default a => a
def {
_tfcMaxLength :: Maybe Int
_tfcMaxLength = forall a. a -> Maybe a
Just Int
len
}
instance WidgetEvent e => CmbOnFocus (TextFieldCfg s e) e Path where
onFocus :: (Path -> e) -> TextFieldCfg s e
onFocus Path -> e
fn = forall a. Default a => a
def {
_tfcOnFocusReq :: [Path -> WidgetRequest s e]
_tfcOnFocusReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
}
instance CmbOnFocusReq (TextFieldCfg s e) s e Path where
onFocusReq :: (Path -> WidgetRequest s e) -> TextFieldCfg s e
onFocusReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
_tfcOnFocusReq :: [Path -> WidgetRequest s e]
_tfcOnFocusReq = [Path -> WidgetRequest s e
req]
}
instance WidgetEvent e => CmbOnBlur (TextFieldCfg s e) e Path where
onBlur :: (Path -> e) -> TextFieldCfg s e
onBlur Path -> e
fn = forall a. Default a => a
def {
_tfcOnBlurReq :: [Path -> WidgetRequest s e]
_tfcOnBlurReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
}
instance CmbOnBlurReq (TextFieldCfg s e) s e Path where
onBlurReq :: (Path -> WidgetRequest s e) -> TextFieldCfg s e
onBlurReq Path -> WidgetRequest s e
req = forall a. Default a => a
def {
_tfcOnBlurReq :: [Path -> WidgetRequest s e]
_tfcOnBlurReq = [Path -> WidgetRequest s e
req]
}
instance WidgetEvent e => CmbOnChange (TextFieldCfg s e) Text e where
onChange :: (Text -> e) -> TextFieldCfg s e
onChange Text -> e
fn = forall a. Default a => a
def {
_tfcOnChangeReq :: [Text -> WidgetRequest s e]
_tfcOnChangeReq = [forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> e
fn]
}
instance CmbOnChangeReq (TextFieldCfg s e) s e Text where
onChangeReq :: (Text -> WidgetRequest s e) -> TextFieldCfg s e
onChangeReq Text -> WidgetRequest s e
req = forall a. Default a => a
def {
_tfcOnChangeReq :: [Text -> WidgetRequest s e]
_tfcOnChangeReq = [Text -> WidgetRequest s e
req]
}
textFieldDisplayChar :: Char -> TextFieldCfg s e
textFieldDisplayChar :: forall s e. Char -> TextFieldCfg s e
textFieldDisplayChar Char
char = forall a. Default a => a
def {
_tfcDisplayChar :: Maybe Char
_tfcDisplayChar = forall a. a -> Maybe a
Just Char
char
}
textField :: WidgetEvent e => ALens' s Text -> WidgetNode s e
textField :: forall e s. WidgetEvent e => ALens' s Text -> WidgetNode s e
textField ALens' s Text
field = forall e s.
WidgetEvent e =>
ALens' s Text -> [TextFieldCfg s e] -> WidgetNode s e
textField_ ALens' s Text
field forall a. Default a => a
def
textField_
:: WidgetEvent e => ALens' s Text -> [TextFieldCfg s e] -> WidgetNode s e
textField_ :: forall e s.
WidgetEvent e =>
ALens' s Text -> [TextFieldCfg s e] -> WidgetNode s e
textField_ ALens' s Text
field [TextFieldCfg s e]
configs = forall e s.
WidgetEvent e =>
WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e
textFieldD_ (forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s Text
field) [TextFieldCfg s e]
configs
textFieldV :: WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e
textFieldV :: forall e s. WidgetEvent e => Text -> (Text -> e) -> WidgetNode s e
textFieldV Text
value Text -> e
handler = forall e s.
WidgetEvent e =>
Text -> (Text -> e) -> [TextFieldCfg s e] -> WidgetNode s e
textFieldV_ Text
value Text -> e
handler forall a. Default a => a
def
textFieldV_
:: WidgetEvent e => Text -> (Text -> e) -> [TextFieldCfg s e] -> WidgetNode s e
textFieldV_ :: forall e s.
WidgetEvent e =>
Text -> (Text -> e) -> [TextFieldCfg s e] -> WidgetNode s e
textFieldV_ Text
value Text -> e
handler [TextFieldCfg s e]
configs = forall e s.
WidgetEvent e =>
WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e
textFieldD_ forall {s}. WidgetData s Text
widgetData [TextFieldCfg s e]
newConfig where
widgetData :: WidgetData s Text
widgetData = forall s a. a -> WidgetData s a
WidgetValue Text
value
newConfig :: [TextFieldCfg s e]
newConfig = forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange Text -> e
handler forall a. a -> [a] -> [a]
: [TextFieldCfg s e]
configs
textFieldD_
:: WidgetEvent e => WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e
textFieldD_ :: forall e s.
WidgetEvent e =>
WidgetData s Text -> [TextFieldCfg s e] -> WidgetNode s e
textFieldD_ WidgetData s Text
widgetData [TextFieldCfg s e]
configs = WidgetNode s e
inputField where
config :: TextFieldCfg s e
config = forall a. Monoid a => [a] -> a
mconcat [TextFieldCfg s e]
configs
fromText :: Text -> Maybe Text
fromText = Maybe Int -> Text -> Maybe Text
textToText (forall s e. TextFieldCfg s e -> Maybe Int
_tfcMaxLength TextFieldCfg s e
config)
inputConfig :: InputFieldCfg s e Text
inputConfig = InputFieldCfg {
_ifcPlaceholder :: Maybe Text
_ifcPlaceholder = forall s e. TextFieldCfg s e -> Maybe Text
_tfcPlaceholder TextFieldCfg s e
config,
_ifcInitialValue :: Text
_ifcInitialValue = Text
"",
_ifcValue :: WidgetData s Text
_ifcValue = WidgetData s Text
widgetData,
_ifcValid :: Maybe (WidgetData s Bool)
_ifcValid = forall s e. TextFieldCfg s e -> Maybe (WidgetData s Bool)
_tfcValid TextFieldCfg s e
config,
_ifcValidV :: [Bool -> e]
_ifcValidV = forall s e. TextFieldCfg s e -> [Bool -> e]
_tfcValidV TextFieldCfg s e
config,
_ifcFromText :: Text -> Maybe Text
_ifcFromText = Text -> Maybe Text
fromText,
_ifcToText :: Text -> Text
_ifcToText = forall a. a -> a
id,
_ifcAcceptInput :: Text -> Bool
_ifcAcceptInput = Maybe Int -> Text -> Bool
acceptInput (forall s e. TextFieldCfg s e -> Maybe Int
_tfcMaxLength TextFieldCfg s e
config),
_ifcIsValidInput :: Text -> Bool
_ifcIsValidInput = Maybe Int -> Text -> Bool
acceptInput (forall s e. TextFieldCfg s e -> Maybe Int
_tfcMaxLength TextFieldCfg s e
config),
_ifcDefCursorEnd :: Bool
_ifcDefCursorEnd = Bool
True,
_ifcDefWidth :: Double
_ifcDefWidth = Double
100,
_ifcCaretWidth :: Maybe Double
_ifcCaretWidth = forall s e. TextFieldCfg s e -> Maybe Double
_tfcCaretWidth TextFieldCfg s e
config,
_ifcCaretMs :: Maybe Millisecond
_ifcCaretMs = forall s e. TextFieldCfg s e -> Maybe Millisecond
_tfcCaretMs TextFieldCfg s e
config,
_ifcDisplayChar :: Maybe Char
_ifcDisplayChar = forall s e. TextFieldCfg s e -> Maybe Char
_tfcDisplayChar TextFieldCfg s e
config,
_ifcResizeOnChange :: Bool
_ifcResizeOnChange = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall s e. TextFieldCfg s e -> Maybe Bool
_tfcResizeOnChange TextFieldCfg s e
config),
_ifcSelectOnFocus :: Bool
_ifcSelectOnFocus = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall s e. TextFieldCfg s e -> Maybe Bool
_tfcSelectOnFocus TextFieldCfg s e
config),
_ifcReadOnly :: Bool
_ifcReadOnly = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall s e. TextFieldCfg s e -> Maybe Bool
_tfcReadOnly TextFieldCfg s e
config),
_ifcStyle :: Maybe (ALens' ThemeState StyleState)
_ifcStyle = forall a. a -> Maybe a
Just forall s a. HasTextFieldStyle s a => Lens' s a
L.textFieldStyle,
_ifcWheelHandler :: Maybe (InputWheelHandler Text)
_ifcWheelHandler = forall a. Maybe a
Nothing,
_ifcDragHandler :: Maybe (InputDragHandler Text)
_ifcDragHandler = forall a. Maybe a
Nothing,
_ifcDragCursor :: Maybe CursorIcon
_ifcDragCursor = forall a. Maybe a
Nothing,
_ifcOnFocusReq :: [Path -> WidgetRequest s e]
_ifcOnFocusReq = forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnFocusReq TextFieldCfg s e
config,
_ifcOnBlurReq :: [Path -> WidgetRequest s e]
_ifcOnBlurReq = forall s e. TextFieldCfg s e -> [Path -> WidgetRequest s e]
_tfcOnBlurReq TextFieldCfg s e
config,
_ifcOnChangeReq :: [Text -> WidgetRequest s e]
_ifcOnChangeReq = forall s e. TextFieldCfg s e -> [Text -> WidgetRequest s e]
_tfcOnChangeReq TextFieldCfg s e
config
}
inputField :: WidgetNode s e
inputField = forall a e s.
(InputFieldValue a, WidgetEvent e) =>
WidgetType -> InputFieldCfg s e a -> WidgetNode s e
inputField_ WidgetType
"textField" InputFieldCfg s e Text
inputConfig
textToText :: Maybe Int -> Text -> Maybe Text
textToText :: Maybe Int -> Text -> Maybe Text
textToText Maybe Int
Nothing Text
text = forall a. a -> Maybe a
Just Text
text
textToText (Just Int
len) Text
text
| Text -> Int
T.length Text
text forall a. Ord a => a -> a -> Bool
<= Int
len = forall a. a -> Maybe a
Just Text
text
| Bool
otherwise = forall a. Maybe a
Nothing
acceptInput :: Maybe Int -> Text -> Bool
acceptInput :: Maybe Int -> Text -> Bool
acceptInput Maybe Int
Nothing Text
_ = Bool
True
acceptInput (Just Int
len) Text
text = Text -> Int
T.length Text
text forall a. Ord a => a -> a -> Bool
<= Int
len