{-|
Module      : Monomer.Widgets.Singles.DateField
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 dates types.

Supports the Day type of the <https://hackage.haskell.org/package/time time>
library, but other types can be supported by implementing 'DayConverter'. Maybe
is also supported.

Supports different date formats and separators.

Handles mouse wheel and shift + vertical drag to increase/decrease days.
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}

module Monomer.Widgets.Singles.DateField (
  -- * Configuration
  DateFieldCfg,
  FormattableDate,
  DayConverter(..),
  DateTextConverter,
  -- * Constructors
  dateField,
  dateField_,
  dateFieldV,
  dateFieldV_,
  dateFormatDelimiter,
  dateFormatDDMMYYYY,
  dateFormatMMDDYYYY,
  dateFormatYYYYMMDD
) where

import Control.Applicative ((<|>))
import Control.Lens ((^.), ALens', _1, _2, _3)
import Control.Monad (join)
import Data.Default
import Data.Either
import Data.Maybe
import Data.Text (Text)
import Data.Time
import Data.Typeable (Typeable, typeOf)

import qualified Data.Attoparsec.Text as A
import qualified Data.Text as T

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

import qualified Monomer.Lens as L
import qualified Monomer.Widgets.Util.Parser as P

data DateFormat
  = FormatDDMMYYYY
  | FormatYYYYMMDD
  | FormatMMDDYYYY
  deriving (DateFormat -> DateFormat -> Bool
(DateFormat -> DateFormat -> Bool)
-> (DateFormat -> DateFormat -> Bool) -> Eq DateFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DateFormat -> DateFormat -> Bool
$c/= :: DateFormat -> DateFormat -> Bool
== :: DateFormat -> DateFormat -> Bool
$c== :: DateFormat -> DateFormat -> Bool
Eq, Int -> DateFormat -> ShowS
[DateFormat] -> ShowS
DateFormat -> String
(Int -> DateFormat -> ShowS)
-> (DateFormat -> String)
-> ([DateFormat] -> ShowS)
-> Show DateFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DateFormat] -> ShowS
$cshowList :: [DateFormat] -> ShowS
show :: DateFormat -> String
$cshow :: DateFormat -> String
showsPrec :: Int -> DateFormat -> ShowS
$cshowsPrec :: Int -> DateFormat -> ShowS
Show)

defaultDateFormat :: DateFormat
defaultDateFormat :: DateFormat
defaultDateFormat = DateFormat
FormatDDMMYYYY

defaultDateDelim :: Char
defaultDateDelim :: Char
defaultDateDelim = Char
'/'

{-|
Converter to and form the Day type of the time library. To use types other than
Day of said library, this typeclass needs to be implemented.
--}
class (Eq a, Ord a, Show a, Typeable a) => DayConverter a where
  convertFromDay :: Day -> a
  convertToDay :: a -> Maybe Day

instance DayConverter Day where
  convertFromDay :: Day -> Day
convertFromDay = Day -> Day
forall a. a -> a
id
  convertToDay :: Day -> Maybe Day
convertToDay = Day -> Maybe Day
forall a. a -> Maybe a
Just

-- | Converts a 'Day' instance to and from 'Text'.
class DateTextConverter a where
  dateAcceptText :: DateFormat -> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
  dateFromText :: DateFormat -> Char -> Text -> Maybe a
  dateToText :: DateFormat -> Char -> a -> Text
  dateFromDay :: Day -> a
  dateToDay :: a -> Maybe Day

instance {-# OVERLAPPABLE #-} DayConverter a => DateTextConverter a where
  dateAcceptText :: DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
dateAcceptText DateFormat
format Char
delim Maybe a
minVal Maybe a
maxVal Text
text = (Bool, Bool, Maybe a)
result where
    accept :: Bool
accept = DateFormat -> Char -> Text -> Bool
acceptTextInput DateFormat
format Char
delim Text
text
    parsed :: Maybe a
parsed = DateFormat -> Char -> Text -> Maybe a
forall a.
DateTextConverter a =>
DateFormat -> Char -> Text -> Maybe a
dateFromText DateFormat
format Char
delim Text
text
    isValid :: Bool
isValid = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
parsed Bool -> Bool -> Bool
&& Maybe a -> Maybe a -> a -> Bool
forall a. Ord a => Maybe a -> Maybe a -> a -> Bool
dateInBounds Maybe a
minVal Maybe a
maxVal (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
parsed)
    fromText :: Maybe a
fromText
      | Bool
isValid = Maybe a
parsed
      | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
    result :: (Bool, Bool, Maybe a)
result = (Bool
accept, Bool
isValid, Maybe a
fromText)
  dateFromText :: DateFormat -> Char -> Text -> Maybe a
dateFromText = DateFormat -> Char -> Text -> Maybe a
forall a.
(DayConverter a, FormattableDate a) =>
DateFormat -> Char -> Text -> Maybe a
dateFromTextSimple
  dateToText :: DateFormat -> Char -> a -> Text
dateToText = DateFormat -> Char -> a -> Text
forall a. FormattableDate a => DateFormat -> Char -> a -> Text
dateToTextSimple
  dateFromDay :: Day -> a
dateFromDay = Day -> a
forall a. DayConverter a => Day -> a
convertFromDay
  dateToDay :: a -> Maybe Day
dateToDay = a -> Maybe Day
forall a. DayConverter a => a -> Maybe Day
convertToDay

instance (DayConverter a, DateTextConverter a) => DateTextConverter (Maybe a) where
  dateAcceptText :: DateFormat
-> Char
-> Maybe (Maybe a)
-> Maybe (Maybe a)
-> Text
-> (Bool, Bool, Maybe (Maybe a))
dateAcceptText DateFormat
format Char
delim Maybe (Maybe a)
minVal Maybe (Maybe a)
maxVal Text
text
    | Text -> Text
T.strip Text
text Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = (Bool
True, Bool
True, Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing)
    | Bool
otherwise = (Bool
accept, Bool
isValid, Maybe (Maybe a)
result) where
      resp :: (Bool, Bool, Maybe a)
resp = DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
forall a.
DateTextConverter a =>
DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
dateAcceptText DateFormat
format Char
delim (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe a)
minVal) (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe a)
maxVal) Text
text
      (Bool
accept, Bool
isValid, Maybe a
tmpResult) = (Bool, Bool, Maybe a)
resp
      result :: Maybe (Maybe a)
result
        | Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
tmpResult = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
tmpResult
        | Bool
otherwise = Maybe (Maybe a)
forall a. Maybe a
Nothing
  dateFromText :: DateFormat -> Char -> Text -> Maybe (Maybe a)
dateFromText DateFormat
format Char
delim = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> (Text -> Maybe a) -> Text -> Maybe (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DateFormat -> Char -> Text -> Maybe a
forall a.
DateTextConverter a =>
DateFormat -> Char -> Text -> Maybe a
dateFromText DateFormat
format Char
delim
  dateToText :: DateFormat -> Char -> Maybe a -> Text
dateToText DateFormat
format Char
delim Maybe a
Nothing = Text
""
  dateToText DateFormat
format Char
delim (Just a
value) = DateFormat -> Char -> a -> Text
forall a. DateTextConverter a => DateFormat -> Char -> a -> Text
dateToText DateFormat
format Char
delim a
value
  dateFromDay :: Day -> Maybe a
dateFromDay = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (Day -> a) -> Day -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> a
forall a. DateTextConverter a => Day -> a
dateFromDay
  dateToDay :: Maybe a -> Maybe Day
dateToDay Maybe a
Nothing = Maybe Day
forall a. Maybe a
Nothing
  dateToDay (Just a
value) = a -> Maybe Day
forall a. DateTextConverter a => a -> Maybe Day
dateToDay a
value

-- | Constraints for date types accepted by dateField.
type FormattableDate a
  = (Eq a, Ord a, Show a, DateTextConverter a, Typeable a)

{-|
Configuration options for dateField:

- '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.
- 'minValue': Minimum valid date.
- 'maxValue': Maximum valid date.
- 'wheelRate': The rate at which wheel movement affects the date.
- 'dragRate': The rate at which drag movement affects the date.
- '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.
- 'dateFormatDelimiter': which text delimiter to separate year, month and day.
- 'dateFormatDDMMYYYY': using the current delimiter, accept DD/MM/YYYY.
- 'dateFormatMMDDYYYY': using the current delimiter, accept MM/DD/YYYY.
- 'dateFormatYYYYMMDD': using the current delimiter, accept YYYY/MM/DD.
-}
data DateFieldCfg s e a = DateFieldCfg {
  DateFieldCfg s e a -> Maybe Double
_dfcCaretWidth :: Maybe Double,
  DateFieldCfg s e a -> Maybe Int
_dfcCaretMs :: Maybe Int,
  DateFieldCfg s e a -> Maybe (WidgetData s Bool)
_dfcValid :: Maybe (WidgetData s Bool),
  DateFieldCfg s e a -> [Bool -> e]
_dfcValidV :: [Bool -> e],
  DateFieldCfg s e a -> Maybe Char
_dfcDateDelim :: Maybe Char,
  DateFieldCfg s e a -> Maybe DateFormat
_dfcDateFormat :: Maybe DateFormat,
  DateFieldCfg s e a -> Maybe a
_dfcMinValue :: Maybe a,
  DateFieldCfg s e a -> Maybe a
_dfcMaxValue :: Maybe a,
  DateFieldCfg s e a -> Maybe Double
_dfcWheelRate :: Maybe Double,
  DateFieldCfg s e a -> Maybe Double
_dfcDragRate :: Maybe Double,
  DateFieldCfg s e a -> Maybe Bool
_dfcResizeOnChange :: Maybe Bool,
  DateFieldCfg s e a -> Maybe Bool
_dfcSelectOnFocus :: Maybe Bool,
  DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnFocusReq :: [Path -> WidgetRequest s e],
  DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnBlurReq :: [Path -> WidgetRequest s e],
  DateFieldCfg s e a -> [a -> WidgetRequest s e]
_dfcOnChangeReq :: [a -> WidgetRequest s e]
}

instance Default (DateFieldCfg s e a) where
  def :: DateFieldCfg s e a
def = DateFieldCfg :: forall s e a.
Maybe Double
-> Maybe Int
-> Maybe (WidgetData s Bool)
-> [Bool -> e]
-> Maybe Char
-> Maybe DateFormat
-> Maybe a
-> Maybe a
-> Maybe Double
-> Maybe Double
-> Maybe Bool
-> Maybe Bool
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [a -> WidgetRequest s e]
-> DateFieldCfg s e a
DateFieldCfg {
    _dfcCaretWidth :: Maybe Double
_dfcCaretWidth = Maybe Double
forall a. Maybe a
Nothing,
    _dfcCaretMs :: Maybe Int
_dfcCaretMs = Maybe Int
forall a. Maybe a
Nothing,
    _dfcValid :: Maybe (WidgetData s Bool)
_dfcValid = Maybe (WidgetData s Bool)
forall a. Maybe a
Nothing,
    _dfcValidV :: [Bool -> e]
_dfcValidV = [],
    _dfcDateDelim :: Maybe Char
_dfcDateDelim = Maybe Char
forall a. Maybe a
Nothing,
    _dfcDateFormat :: Maybe DateFormat
_dfcDateFormat = Maybe DateFormat
forall a. Maybe a
Nothing,
    _dfcMinValue :: Maybe a
_dfcMinValue = Maybe a
forall a. Maybe a
Nothing,
    _dfcMaxValue :: Maybe a
_dfcMaxValue = Maybe a
forall a. Maybe a
Nothing,
    _dfcWheelRate :: Maybe Double
_dfcWheelRate = Maybe Double
forall a. Maybe a
Nothing,
    _dfcDragRate :: Maybe Double
_dfcDragRate = Maybe Double
forall a. Maybe a
Nothing,
    _dfcResizeOnChange :: Maybe Bool
_dfcResizeOnChange = Maybe Bool
forall a. Maybe a
Nothing,
    _dfcSelectOnFocus :: Maybe Bool
_dfcSelectOnFocus = Maybe Bool
forall a. Maybe a
Nothing,
    _dfcOnFocusReq :: [Path -> WidgetRequest s e]
_dfcOnFocusReq = [],
    _dfcOnBlurReq :: [Path -> WidgetRequest s e]
_dfcOnBlurReq = [],
    _dfcOnChangeReq :: [a -> WidgetRequest s e]
_dfcOnChangeReq = []
  }

instance Semigroup (DateFieldCfg s e a) where
  <> :: DateFieldCfg s e a -> DateFieldCfg s e a -> DateFieldCfg s e a
(<>) DateFieldCfg s e a
t1 DateFieldCfg s e a
t2 = DateFieldCfg :: forall s e a.
Maybe Double
-> Maybe Int
-> Maybe (WidgetData s Bool)
-> [Bool -> e]
-> Maybe Char
-> Maybe DateFormat
-> Maybe a
-> Maybe a
-> Maybe Double
-> Maybe Double
-> Maybe Bool
-> Maybe Bool
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [a -> WidgetRequest s e]
-> DateFieldCfg s e a
DateFieldCfg {
    _dfcCaretWidth :: Maybe Double
_dfcCaretWidth = DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcCaretWidth DateFieldCfg s e a
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcCaretWidth DateFieldCfg s e a
t1,
    _dfcCaretMs :: Maybe Int
_dfcCaretMs = DateFieldCfg s e a -> Maybe Int
forall s e a. DateFieldCfg s e a -> Maybe Int
_dfcCaretMs DateFieldCfg s e a
t2 Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Int
forall s e a. DateFieldCfg s e a -> Maybe Int
_dfcCaretMs DateFieldCfg s e a
t1,
    _dfcValid :: Maybe (WidgetData s Bool)
_dfcValid = DateFieldCfg s e a -> Maybe (WidgetData s Bool)
forall s e a. DateFieldCfg s e a -> Maybe (WidgetData s Bool)
_dfcValid DateFieldCfg s e a
t2 Maybe (WidgetData s Bool)
-> Maybe (WidgetData s Bool) -> Maybe (WidgetData s Bool)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe (WidgetData s Bool)
forall s e a. DateFieldCfg s e a -> Maybe (WidgetData s Bool)
_dfcValid DateFieldCfg s e a
t1,
    _dfcValidV :: [Bool -> e]
_dfcValidV = DateFieldCfg s e a -> [Bool -> e]
forall s e a. DateFieldCfg s e a -> [Bool -> e]
_dfcValidV DateFieldCfg s e a
t1 [Bool -> e] -> [Bool -> e] -> [Bool -> e]
forall a. Semigroup a => a -> a -> a
<> DateFieldCfg s e a -> [Bool -> e]
forall s e a. DateFieldCfg s e a -> [Bool -> e]
_dfcValidV DateFieldCfg s e a
t2,
    _dfcDateDelim :: Maybe Char
_dfcDateDelim = DateFieldCfg s e a -> Maybe Char
forall s e a. DateFieldCfg s e a -> Maybe Char
_dfcDateDelim DateFieldCfg s e a
t2 Maybe Char -> Maybe Char -> Maybe Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Char
forall s e a. DateFieldCfg s e a -> Maybe Char
_dfcDateDelim DateFieldCfg s e a
t1,
    _dfcDateFormat :: Maybe DateFormat
_dfcDateFormat = DateFieldCfg s e a -> Maybe DateFormat
forall s e a. DateFieldCfg s e a -> Maybe DateFormat
_dfcDateFormat DateFieldCfg s e a
t2 Maybe DateFormat -> Maybe DateFormat -> Maybe DateFormat
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe DateFormat
forall s e a. DateFieldCfg s e a -> Maybe DateFormat
_dfcDateFormat DateFieldCfg s e a
t1,
    _dfcMinValue :: Maybe a
_dfcMinValue = DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMinValue DateFieldCfg s e a
t2 Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMinValue DateFieldCfg s e a
t1,
    _dfcMaxValue :: Maybe a
_dfcMaxValue = DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMaxValue DateFieldCfg s e a
t2 Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMaxValue DateFieldCfg s e a
t1,
    _dfcWheelRate :: Maybe Double
_dfcWheelRate = DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcWheelRate DateFieldCfg s e a
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcWheelRate DateFieldCfg s e a
t1,
    _dfcDragRate :: Maybe Double
_dfcDragRate = DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcDragRate DateFieldCfg s e a
t2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcDragRate DateFieldCfg s e a
t1,
    _dfcResizeOnChange :: Maybe Bool
_dfcResizeOnChange = DateFieldCfg s e a -> Maybe Bool
forall s e a. DateFieldCfg s e a -> Maybe Bool
_dfcResizeOnChange DateFieldCfg s e a
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Bool
forall s e a. DateFieldCfg s e a -> Maybe Bool
_dfcResizeOnChange DateFieldCfg s e a
t1,
    _dfcSelectOnFocus :: Maybe Bool
_dfcSelectOnFocus = DateFieldCfg s e a -> Maybe Bool
forall s e a. DateFieldCfg s e a -> Maybe Bool
_dfcSelectOnFocus DateFieldCfg s e a
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> DateFieldCfg s e a -> Maybe Bool
forall s e a. DateFieldCfg s e a -> Maybe Bool
_dfcSelectOnFocus DateFieldCfg s e a
t1,
    _dfcOnFocusReq :: [Path -> WidgetRequest s e]
_dfcOnFocusReq = DateFieldCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnFocusReq DateFieldCfg s e a
t1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> DateFieldCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnFocusReq DateFieldCfg s e a
t2,
    _dfcOnBlurReq :: [Path -> WidgetRequest s e]
_dfcOnBlurReq = DateFieldCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnBlurReq DateFieldCfg s e a
t1 [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e] -> [Path -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> DateFieldCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnBlurReq DateFieldCfg s e a
t2,
    _dfcOnChangeReq :: [a -> WidgetRequest s e]
_dfcOnChangeReq = DateFieldCfg s e a -> [a -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [a -> WidgetRequest s e]
_dfcOnChangeReq DateFieldCfg s e a
t1 [a -> WidgetRequest s e]
-> [a -> WidgetRequest s e] -> [a -> WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> DateFieldCfg s e a -> [a -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [a -> WidgetRequest s e]
_dfcOnChangeReq DateFieldCfg s e a
t2
  }

instance Monoid (DateFieldCfg s e a) where
  mempty :: DateFieldCfg s e a
mempty = DateFieldCfg s e a
forall a. Default a => a
def

instance CmbCaretWidth (DateFieldCfg s e a) Double where
  caretWidth :: Double -> DateFieldCfg s e a
caretWidth Double
w = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcCaretWidth :: Maybe Double
_dfcCaretWidth = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w
  }

instance CmbCaretMs (DateFieldCfg s e a) Int where
  caretMs :: Int -> DateFieldCfg s e a
caretMs Int
ms = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcCaretMs :: Maybe Int
_dfcCaretMs = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
ms
  }

instance CmbValidInput (DateFieldCfg s e a) s where
  validInput :: ALens' s Bool -> DateFieldCfg s e a
validInput ALens' s Bool
field = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcValid :: Maybe (WidgetData s Bool)
_dfcValid = WidgetData s Bool -> Maybe (WidgetData s Bool)
forall a. a -> Maybe a
Just (ALens' s Bool -> WidgetData s Bool
forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s Bool
field)
  }

instance CmbValidInputV (DateFieldCfg s e a) e where
  validInputV :: (Bool -> e) -> DateFieldCfg s e a
validInputV Bool -> e
fn = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcValidV :: [Bool -> e]
_dfcValidV = [Bool -> e
fn]
  }

instance CmbResizeOnChange (DateFieldCfg s e a) where
  resizeOnChange_ :: Bool -> DateFieldCfg s e a
resizeOnChange_ Bool
resize = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcResizeOnChange :: Maybe Bool
_dfcResizeOnChange = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
resize
  }

instance CmbSelectOnFocus (DateFieldCfg s e a) where
  selectOnFocus_ :: Bool -> DateFieldCfg s e a
selectOnFocus_ Bool
sel = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcSelectOnFocus :: Maybe Bool
_dfcSelectOnFocus = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
sel
  }

instance FormattableDate a => CmbMinValue (DateFieldCfg s e a) a where
  minValue :: a -> DateFieldCfg s e a
minValue a
len = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcMinValue :: Maybe a
_dfcMinValue = a -> Maybe a
forall a. a -> Maybe a
Just a
len
  }

instance FormattableDate a => CmbMaxValue (DateFieldCfg s e a) a where
  maxValue :: a -> DateFieldCfg s e a
maxValue a
len = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcMaxValue :: Maybe a
_dfcMaxValue = a -> Maybe a
forall a. a -> Maybe a
Just a
len
  }

instance CmbWheelRate (DateFieldCfg s e a) Double where
  wheelRate :: Double -> DateFieldCfg s e a
wheelRate Double
rate = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcWheelRate :: Maybe Double
_dfcWheelRate = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
rate
  }

instance CmbDragRate (DateFieldCfg s e a) Double where
  dragRate :: Double -> DateFieldCfg s e a
dragRate Double
rate = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcDragRate :: Maybe Double
_dfcDragRate = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
rate
  }

instance WidgetEvent e => CmbOnFocus (DateFieldCfg s e a) e Path where
  onFocus :: (Path -> e) -> DateFieldCfg s e a
onFocus Path -> e
fn = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcOnFocusReq :: [Path -> WidgetRequest s e]
_dfcOnFocusReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Path -> e) -> Path -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnFocusReq (DateFieldCfg s e a) s e Path where
  onFocusReq :: (Path -> WidgetRequest s e) -> DateFieldCfg s e a
onFocusReq Path -> WidgetRequest s e
req = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcOnFocusReq :: [Path -> WidgetRequest s e]
_dfcOnFocusReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnBlur (DateFieldCfg s e a) e Path where
  onBlur :: (Path -> e) -> DateFieldCfg s e a
onBlur Path -> e
fn = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcOnBlurReq :: [Path -> WidgetRequest s e]
_dfcOnBlurReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e)
-> (Path -> e) -> Path -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> e
fn]
  }

instance CmbOnBlurReq (DateFieldCfg s e a) s e Path where
  onBlurReq :: (Path -> WidgetRequest s e) -> DateFieldCfg s e a
onBlurReq Path -> WidgetRequest s e
req = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcOnBlurReq :: [Path -> WidgetRequest s e]
_dfcOnBlurReq = [Path -> WidgetRequest s e
req]
  }

instance WidgetEvent e => CmbOnChange (DateFieldCfg s e a) a e where
  onChange :: (a -> e) -> DateFieldCfg s e a
onChange a -> e
fn = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcOnChangeReq :: [a -> WidgetRequest s e]
_dfcOnChangeReq = [e -> WidgetRequest s e
forall s e. WidgetEvent e => e -> WidgetRequest s e
RaiseEvent (e -> WidgetRequest s e) -> (a -> e) -> a -> WidgetRequest s e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e
fn]
  }

instance CmbOnChangeReq (DateFieldCfg s e a) s e a where
  onChangeReq :: (a -> WidgetRequest s e) -> DateFieldCfg s e a
onChangeReq a -> WidgetRequest s e
req = DateFieldCfg s e a
forall a. Default a => a
def {
    _dfcOnChangeReq :: [a -> WidgetRequest s e]
_dfcOnChangeReq = [a -> WidgetRequest s e
req]
  }

-- | Which character should be used to delimit dates.
dateFormatDelimiter :: Char -> DateFieldCfg s e a
dateFormatDelimiter :: Char -> DateFieldCfg s e a
dateFormatDelimiter Char
delim = DateFieldCfg s e a
forall a. Default a => a
def {
  _dfcDateDelim :: Maybe Char
_dfcDateDelim = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
delim
}

-- | Date format DD/MM/YYYY, using the appropriate delimiter.
dateFormatDDMMYYYY :: DateFieldCfg s e a
dateFormatDDMMYYYY :: DateFieldCfg s e a
dateFormatDDMMYYYY = DateFieldCfg s e a
forall a. Default a => a
def {
  _dfcDateFormat :: Maybe DateFormat
_dfcDateFormat = DateFormat -> Maybe DateFormat
forall a. a -> Maybe a
Just DateFormat
FormatDDMMYYYY
}

-- | Date format MM/DD/YYYY, using the appropriate delimiter.
dateFormatMMDDYYYY :: DateFieldCfg s e a
dateFormatMMDDYYYY :: DateFieldCfg s e a
dateFormatMMDDYYYY = DateFieldCfg s e a
forall a. Default a => a
def {
  _dfcDateFormat :: Maybe DateFormat
_dfcDateFormat = DateFormat -> Maybe DateFormat
forall a. a -> Maybe a
Just DateFormat
FormatMMDDYYYY
}

-- | Date format YYYY/MM/DD, using the appropriate delimiter.
dateFormatYYYYMMDD :: DateFieldCfg s e a
dateFormatYYYYMMDD :: DateFieldCfg s e a
dateFormatYYYYMMDD = DateFieldCfg s e a
forall a. Default a => a
def {
  _dfcDateFormat :: Maybe DateFormat
_dfcDateFormat = DateFormat -> Maybe DateFormat
forall a. a -> Maybe a
Just DateFormat
FormatYYYYMMDD
}

-- | Creates a date field using the given lens.
dateField
  :: (FormattableDate a, WidgetEvent e)
  => ALens' s a -> WidgetNode s e
dateField :: ALens' s a -> WidgetNode s e
dateField ALens' s a
field = ALens' s a -> [DateFieldCfg s e a] -> WidgetNode s e
forall a e s.
(FormattableDate a, WidgetEvent e) =>
ALens' s a -> [DateFieldCfg s e a] -> WidgetNode s e
dateField_ ALens' s a
field [DateFieldCfg s e a]
forall a. Default a => a
def

-- | Creates a date field using the given lens. Accepts config.
dateField_
  :: (FormattableDate a, WidgetEvent e)
  => ALens' s a
  -> [DateFieldCfg s e a]
  -> WidgetNode s e
dateField_ :: ALens' s a -> [DateFieldCfg s e a] -> WidgetNode s e
dateField_ ALens' s a
field [DateFieldCfg s e a]
configs = WidgetNode s e
widget where
  widget :: WidgetNode s e
widget = WidgetData s a -> [DateFieldCfg s e a] -> WidgetNode s e
forall a e s.
(FormattableDate a, WidgetEvent e) =>
WidgetData s a -> [DateFieldCfg s e a] -> WidgetNode s e
dateFieldD_ (ALens' s a -> WidgetData s a
forall s a. ALens' s a -> WidgetData s a
WidgetLens ALens' s a
field) [DateFieldCfg s e a]
configs

-- | Creates a date field using the given value and 'onChange' event handler.
dateFieldV
  :: (FormattableDate a, WidgetEvent e)
  => a -> (a -> e) -> WidgetNode s e
dateFieldV :: a -> (a -> e) -> WidgetNode s e
dateFieldV a
value a -> e
handler = a -> (a -> e) -> [DateFieldCfg s e a] -> WidgetNode s e
forall a e s.
(FormattableDate a, WidgetEvent e) =>
a -> (a -> e) -> [DateFieldCfg s e a] -> WidgetNode s e
dateFieldV_ a
value a -> e
handler [DateFieldCfg s e a]
forall a. Default a => a
def

-- | Creates a date field using the given value and 'onChange' event handler.
--   Accepts config.
dateFieldV_
  :: (FormattableDate a, WidgetEvent e)
  => a
  -> (a -> e)
  -> [DateFieldCfg s e a]
  -> WidgetNode s e
dateFieldV_ :: a -> (a -> e) -> [DateFieldCfg s e a] -> WidgetNode s e
dateFieldV_ a
value a -> e
handler [DateFieldCfg s e a]
configs = WidgetNode s e
newNode where
  widgetData :: WidgetData s a
widgetData = a -> WidgetData s a
forall s a. a -> WidgetData s a
WidgetValue a
value
  newConfigs :: [DateFieldCfg s e a]
newConfigs = (a -> e) -> DateFieldCfg s e a
forall t a e. CmbOnChange t a e => (a -> e) -> t
onChange a -> e
handler DateFieldCfg s e a -> [DateFieldCfg s e a] -> [DateFieldCfg s e a]
forall a. a -> [a] -> [a]
: [DateFieldCfg s e a]
configs
  newNode :: WidgetNode s e
newNode = WidgetData s a -> [DateFieldCfg s e a] -> WidgetNode s e
forall a e s.
(FormattableDate a, WidgetEvent e) =>
WidgetData s a -> [DateFieldCfg s e a] -> WidgetNode s e
dateFieldD_ WidgetData s a
forall s. WidgetData s a
widgetData [DateFieldCfg s e a]
newConfigs

-- | Creates a date field providing a 'WidgetData' instance and config.
dateFieldD_
  :: (FormattableDate a, WidgetEvent e)
  => WidgetData s a
  -> [DateFieldCfg s e a]
  -> WidgetNode s e
dateFieldD_ :: WidgetData s a -> [DateFieldCfg s e a] -> WidgetNode s e
dateFieldD_ WidgetData s a
widgetData [DateFieldCfg s e a]
configs = WidgetNode s e
newNode where
  config :: DateFieldCfg s e a
config = [DateFieldCfg s e a] -> DateFieldCfg s e a
forall a. Monoid a => [a] -> a
mconcat [DateFieldCfg s e a]
configs
  format :: DateFormat
format = DateFormat -> Maybe DateFormat -> DateFormat
forall a. a -> Maybe a -> a
fromMaybe DateFormat
defaultDateFormat (DateFieldCfg s e a -> Maybe DateFormat
forall s e a. DateFieldCfg s e a -> Maybe DateFormat
_dfcDateFormat DateFieldCfg s e a
config)
  delim :: Char
delim = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
defaultDateDelim (DateFieldCfg s e a -> Maybe Char
forall s e a. DateFieldCfg s e a -> Maybe Char
_dfcDateDelim DateFieldCfg s e a
config)
  minVal :: Maybe a
minVal = DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMinValue DateFieldCfg s e a
config
  maxVal :: Maybe a
maxVal = DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMaxValue DateFieldCfg s e a
config

  initialValue :: a
initialValue
    | Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
minVal = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
minVal
    | Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
maxVal = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
maxVal
    | Bool
otherwise = Day -> a
forall a. DateTextConverter a => Day -> a
dateFromDay (Integer -> Int -> Int -> Day
fromGregorian Integer
1970 Int
1 Int
1)

  acceptText :: Text -> (Bool, Bool, Maybe a)
acceptText = DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
forall a.
DateTextConverter a =>
DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
dateAcceptText DateFormat
format Char
delim Maybe a
minVal Maybe a
maxVal
  acceptInput :: Text -> Bool
acceptInput Text
text = Text -> (Bool, Bool, Maybe a)
acceptText Text
text (Bool, Bool, Maybe a)
-> Getting Bool (Bool, Bool, Maybe a) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool (Bool, Bool, Maybe a) Bool
forall s t a b. Field1 s t a b => Lens s t a b
_1
  validInput :: Text -> Bool
validInput Text
text = Text -> (Bool, Bool, Maybe a)
acceptText Text
text (Bool, Bool, Maybe a)
-> Getting Bool (Bool, Bool, Maybe a) Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool (Bool, Bool, Maybe a) Bool
forall s t a b. Field2 s t a b => Lens s t a b
_2
  fromText :: Text -> Maybe a
fromText Text
text = Text -> (Bool, Bool, Maybe a)
acceptText Text
text (Bool, Bool, Maybe a)
-> Getting (Maybe a) (Bool, Bool, Maybe a) (Maybe a) -> Maybe a
forall s a. s -> Getting a s a -> a
^. Getting (Maybe a) (Bool, Bool, Maybe a) (Maybe a)
forall s t a b. Field3 s t a b => Lens s t a b
_3
  toText :: a -> Text
toText = DateFormat -> Char -> a -> Text
forall a. DateTextConverter a => DateFormat -> Char -> a -> Text
dateToText DateFormat
format Char
delim

  inputConfig :: InputFieldCfg s e a
inputConfig = InputFieldCfg :: forall s e a.
Maybe Text
-> a
-> WidgetData s a
-> Maybe (WidgetData s Bool)
-> [Bool -> e]
-> Bool
-> Double
-> Maybe Double
-> Maybe Int
-> Maybe Char
-> Bool
-> Bool
-> (Text -> Maybe a)
-> (a -> Text)
-> (Text -> Bool)
-> (Text -> Bool)
-> Maybe (ALens' ThemeState StyleState)
-> Maybe (InputWheelHandler a)
-> Maybe (InputDragHandler a)
-> Maybe CursorIcon
-> [Path -> WidgetRequest s e]
-> [Path -> WidgetRequest s e]
-> [a -> WidgetRequest s e]
-> InputFieldCfg s e a
InputFieldCfg {
    _ifcPlaceholder :: Maybe Text
_ifcPlaceholder = Maybe Text
forall a. Maybe a
Nothing,
    _ifcInitialValue :: a
_ifcInitialValue = a
initialValue,
    _ifcValue :: WidgetData s a
_ifcValue = WidgetData s a
widgetData,
    _ifcValid :: Maybe (WidgetData s Bool)
_ifcValid = DateFieldCfg s e a -> Maybe (WidgetData s Bool)
forall s e a. DateFieldCfg s e a -> Maybe (WidgetData s Bool)
_dfcValid DateFieldCfg s e a
config,
    _ifcValidV :: [Bool -> e]
_ifcValidV = DateFieldCfg s e a -> [Bool -> e]
forall s e a. DateFieldCfg s e a -> [Bool -> e]
_dfcValidV DateFieldCfg s e a
config,
    _ifcFromText :: Text -> Maybe a
_ifcFromText = Text -> Maybe a
fromText,
    _ifcToText :: a -> Text
_ifcToText = a -> Text
toText,
    _ifcAcceptInput :: Text -> Bool
_ifcAcceptInput = Text -> Bool
acceptInput,
    _ifcIsValidInput :: Text -> Bool
_ifcIsValidInput = Text -> Bool
validInput,
    _ifcDefCursorEnd :: Bool
_ifcDefCursorEnd = Bool
True,
    _ifcDefWidth :: Double
_ifcDefWidth = Double
160,
    _ifcCaretWidth :: Maybe Double
_ifcCaretWidth = DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcCaretWidth DateFieldCfg s e a
config,
    _ifcCaretMs :: Maybe Int
_ifcCaretMs = DateFieldCfg s e a -> Maybe Int
forall s e a. DateFieldCfg s e a -> Maybe Int
_dfcCaretMs DateFieldCfg s e a
config,
    _ifcDisplayChar :: Maybe Char
_ifcDisplayChar = Maybe Char
forall a. Maybe a
Nothing,
    _ifcResizeOnChange :: Bool
_ifcResizeOnChange = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (DateFieldCfg s e a -> Maybe Bool
forall s e a. DateFieldCfg s e a -> Maybe Bool
_dfcResizeOnChange DateFieldCfg s e a
config),
    _ifcSelectOnFocus :: Bool
_ifcSelectOnFocus = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (DateFieldCfg s e a -> Maybe Bool
forall s e a. DateFieldCfg s e a -> Maybe Bool
_dfcSelectOnFocus DateFieldCfg s e a
config),
    _ifcStyle :: Maybe (ALens' ThemeState StyleState)
_ifcStyle = ALens' ThemeState StyleState
-> Maybe (ALens' ThemeState StyleState)
forall a. a -> Maybe a
Just ALens' ThemeState StyleState
forall s a. HasDateFieldStyle s a => Lens' s a
L.dateFieldStyle,
    _ifcWheelHandler :: Maybe (InputWheelHandler a)
_ifcWheelHandler = InputWheelHandler a -> Maybe (InputWheelHandler a)
forall a. a -> Maybe a
Just (DateFieldCfg s e a -> InputWheelHandler a
forall a s e.
FormattableDate a =>
DateFieldCfg s e a
-> InputFieldState a
-> Point
-> Point
-> WheelDirection
-> (Text, Int, Maybe Int)
handleWheel DateFieldCfg s e a
config),
    _ifcDragHandler :: Maybe (InputDragHandler a)
_ifcDragHandler = InputDragHandler a -> Maybe (InputDragHandler a)
forall a. a -> Maybe a
Just (DateFieldCfg s e a -> InputDragHandler a
forall a s e.
FormattableDate a =>
DateFieldCfg s e a
-> InputFieldState a -> Point -> Point -> (Text, Int, Maybe Int)
handleDrag DateFieldCfg s e a
config),
    _ifcDragCursor :: Maybe CursorIcon
_ifcDragCursor = CursorIcon -> Maybe CursorIcon
forall a. a -> Maybe a
Just CursorIcon
CursorSizeV,
    _ifcOnFocusReq :: [Path -> WidgetRequest s e]
_ifcOnFocusReq = DateFieldCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnFocusReq DateFieldCfg s e a
config,
    _ifcOnBlurReq :: [Path -> WidgetRequest s e]
_ifcOnBlurReq = DateFieldCfg s e a -> [Path -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [Path -> WidgetRequest s e]
_dfcOnBlurReq DateFieldCfg s e a
config,
    _ifcOnChangeReq :: [a -> WidgetRequest s e]
_ifcOnChangeReq = DateFieldCfg s e a -> [a -> WidgetRequest s e]
forall s e a. DateFieldCfg s e a -> [a -> WidgetRequest s e]
_dfcOnChangeReq DateFieldCfg s e a
config
  }
  newNode :: WidgetNode s e
newNode = WidgetType -> InputFieldCfg s e a -> WidgetNode s e
forall a e s.
(InputFieldValue a, WidgetEvent e) =>
WidgetType -> InputFieldCfg s e a -> WidgetNode s e
inputField_ WidgetType
"dateField" InputFieldCfg s e a
inputConfig

handleWheel
  :: FormattableDate a
  => DateFieldCfg s e a
  -> InputFieldState a
  -> Point
  -> Point
  -> WheelDirection
  -> (Text, Int, Maybe Int)
handleWheel :: DateFieldCfg s e a
-> InputFieldState a
-> Point
-> Point
-> WheelDirection
-> (Text, Int, Maybe Int)
handleWheel DateFieldCfg s e a
config InputFieldState a
state Point
point Point
move WheelDirection
dir = (Text, Int, Maybe Int)
result where
  Point Double
_ Double
dy = Point
move
  sign :: Double
sign = if WheelDirection
dir WheelDirection -> WheelDirection -> Bool
forall a. Eq a => a -> a -> Bool
== WheelDirection
WheelNormal then Double
1 else -Double
1
  curValue :: a
curValue = InputFieldState a -> a
forall a. InputFieldState a -> a
_ifsCurrValue InputFieldState a
state
  wheelRate :: Double
wheelRate = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcWheelRate DateFieldCfg s e a
config)
  result :: (Text, Int, Maybe Int)
result = DateFieldCfg s e a
-> InputFieldState a
-> Double
-> a
-> Double
-> (Text, Int, Maybe Int)
forall a s e.
FormattableDate a =>
DateFieldCfg s e a
-> InputFieldState a
-> Double
-> a
-> Double
-> (Text, Int, Maybe Int)
handleMove DateFieldCfg s e a
config InputFieldState a
state Double
wheelRate a
curValue (Double
dy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sign)

handleDrag
  :: FormattableDate a
  => DateFieldCfg s e a
  -> InputFieldState a
  -> Point
  -> Point
  -> (Text, Int, Maybe Int)
handleDrag :: DateFieldCfg s e a
-> InputFieldState a -> Point -> Point -> (Text, Int, Maybe Int)
handleDrag DateFieldCfg s e a
config InputFieldState a
state Point
clickPos Point
currPos = (Text, Int, Maybe Int)
result where
  Point Double
_ Double
dy = Point -> Point -> Point
subPoint Point
clickPos Point
currPos
  selValue :: a
selValue = InputFieldState a -> a
forall a. InputFieldState a -> a
_ifsDragSelValue InputFieldState a
state
  dragRate :: Double
dragRate = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (DateFieldCfg s e a -> Maybe Double
forall s e a. DateFieldCfg s e a -> Maybe Double
_dfcDragRate DateFieldCfg s e a
config)
  result :: (Text, Int, Maybe Int)
result = DateFieldCfg s e a
-> InputFieldState a
-> Double
-> a
-> Double
-> (Text, Int, Maybe Int)
forall a s e.
FormattableDate a =>
DateFieldCfg s e a
-> InputFieldState a
-> Double
-> a
-> Double
-> (Text, Int, Maybe Int)
handleMove DateFieldCfg s e a
config InputFieldState a
state Double
dragRate a
selValue Double
dy

handleMove
  :: FormattableDate a
  => DateFieldCfg s e a
  -> InputFieldState a
  -> Double
  -> a
  -> Double
  -> (Text, Int, Maybe Int)
handleMove :: DateFieldCfg s e a
-> InputFieldState a
-> Double
-> a
-> Double
-> (Text, Int, Maybe Int)
handleMove DateFieldCfg s e a
config InputFieldState a
state Double
rate a
value Double
dy = (Text, Int, Maybe Int)
result where
  format :: DateFormat
format = DateFormat -> Maybe DateFormat -> DateFormat
forall a. a -> Maybe a -> a
fromMaybe DateFormat
defaultDateFormat (DateFieldCfg s e a -> Maybe DateFormat
forall s e a. DateFieldCfg s e a -> Maybe DateFormat
_dfcDateFormat DateFieldCfg s e a
config)
  delim :: Char
delim = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
defaultDateDelim (DateFieldCfg s e a -> Maybe Char
forall s e a. DateFieldCfg s e a -> Maybe Char
_dfcDateDelim DateFieldCfg s e a
config)
  minVal :: Maybe a
minVal = DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMinValue DateFieldCfg s e a
config
  maxVal :: Maybe a
maxVal = DateFieldCfg s e a -> Maybe a
forall s e a. DateFieldCfg s e a -> Maybe a
_dfcMaxValue DateFieldCfg s e a
config

  acceptText :: Text -> (Bool, Bool, Maybe a)
acceptText = DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
forall a.
DateTextConverter a =>
DateFormat
-> Char -> Maybe a -> Maybe a -> Text -> (Bool, Bool, Maybe a)
dateAcceptText DateFormat
format Char
delim Maybe a
minVal Maybe a
maxVal
  fromText :: Text -> Maybe a
fromText Text
text = Text -> (Bool, Bool, Maybe a)
acceptText Text
text (Bool, Bool, Maybe a)
-> Getting (Maybe a) (Bool, Bool, Maybe a) (Maybe a) -> Maybe a
forall s a. s -> Getting a s a -> a
^. Getting (Maybe a) (Bool, Bool, Maybe a) (Maybe a)
forall s t a b. Field3 s t a b => Lens s t a b
_3
  toText :: a -> Text
toText = DateFormat -> Char -> a -> Text
forall a. DateTextConverter a => DateFormat -> Char -> a -> Text
dateToText DateFormat
format Char
delim

  (Bool
valid, Maybe a
mParsedVal, a
parsedVal) = case a -> Maybe Day
forall a. DateTextConverter a => a -> Maybe Day
dateToDay a
value of
    Just Day
val -> (Bool
True, Maybe a
mParsedVal, a
parsedVal) where
      tmpValue :: Day
tmpValue = Integer -> Day -> Day
addDays (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
dy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rate)) Day
val
      mParsedVal :: Maybe a
mParsedVal = Text -> Maybe a
fromText (a -> Text
toText (Day -> a
forall a. DateTextConverter a => Day -> a
dateFromDay Day
tmpValue))
      parsedVal :: a
parsedVal = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
mParsedVal
    Maybe Day
Nothing -> (Bool
False, Maybe a
forall a. Maybe a
Nothing, a
forall a. HasCallStack => a
undefined)
  newVal :: a
newVal
    | Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
mParsedVal = a
parsedVal
    | Bool
valid Bool -> Bool -> Bool
&& Double
dy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
maxVal = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
maxVal
    | Bool
valid Bool -> Bool -> Bool
&& Double
dy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
&& Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
minVal = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
minVal
    | Bool
otherwise = InputFieldState a -> a
forall a. InputFieldState a -> a
_ifsCurrValue InputFieldState a
state

  newText :: Text
newText = a -> Text
toText a
newVal
  newPos :: Int
newPos = InputFieldState a -> Int
forall a. InputFieldState a -> Int
_ifsCursorPos InputFieldState a
state
  newSel :: Maybe Int
newSel = InputFieldState a -> Maybe Int
forall a. InputFieldState a -> Maybe Int
_ifsSelStart InputFieldState a
state
  result :: (Text, Int, Maybe Int)
result = (Text
newText, Int
newPos, Maybe Int
newSel)

dateFromTextSimple
  :: (DayConverter a, FormattableDate a)
  => DateFormat
  -> Char
  -> Text
  -> Maybe a
dateFromTextSimple :: DateFormat -> Char -> Text -> Maybe a
dateFromTextSimple DateFormat
format Char
delim Text
text = Maybe a
newDate where
  compParser :: Parser Text Int
compParser = Char -> Parser Char
A.char Char
delim Parser Char -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Int
forall a. Integral a => Parser a
A.decimal
  dateParser :: Parser Text (Int, Int, Int)
dateParser = (,,) (Int -> Int -> Int -> (Int, Int, Int))
-> Parser Text Int -> Parser Text (Int -> Int -> (Int, Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
forall a. Integral a => Parser a
A.decimal Parser Text (Int -> Int -> (Int, Int, Int))
-> Parser Text Int -> Parser Text (Int -> (Int, Int, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Int
compParser Parser Text (Int -> (Int, Int, Int))
-> Parser Text Int -> Parser Text (Int, Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Int
compParser
  tmpDate :: Maybe Day
tmpDate = case Parser Text (Int, Int, Int)
-> Text -> Either String (Int, Int, Int)
forall a. Parser a -> Text -> Either String a
A.parseOnly Parser Text (Int, Int, Int)
dateParser Text
text of
    Left String
_ -> Maybe Day
forall a. Maybe a
Nothing
    Right (Int
n1, Int
n2, Int
n3)
      | DateFormat
format DateFormat -> DateFormat -> Bool
forall a. Eq a => a -> a -> Bool
== DateFormat
FormatDDMMYYYY -> Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n3) Int
n2 Int
n1
      | DateFormat
format DateFormat -> DateFormat -> Bool
forall a. Eq a => a -> a -> Bool
== DateFormat
FormatMMDDYYYY -> Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n3) Int
n1 Int
n2
      | Bool
otherwise -> Integer -> Int -> Int -> Maybe Day
fromGregorianValid (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n1) Int
n2 Int
n3
  newDate :: Maybe a
newDate = Maybe Day
tmpDate Maybe Day -> (Day -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Day -> Maybe a
forall a. DateTextConverter a => Day -> a
dateFromDay

dateToTextSimple :: FormattableDate a => DateFormat -> Char -> a -> Text
dateToTextSimple :: DateFormat -> Char -> a -> Text
dateToTextSimple DateFormat
format Char
delim a
val = Text
result where
  converted :: Maybe Day
converted = a -> Maybe Day
forall a. DateTextConverter a => a -> Maybe Day
dateToDay a
val
  (Integer
year, Int
month, Int
day) = Day -> (Integer, Int, Int)
toGregorian (Maybe Day -> Day
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Day
converted)
  sep :: Text
sep = Char -> Text
T.singleton Char
delim
  padd :: a -> Text
padd a
num
    | a
num a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10 = Text
"0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
num)
    | Bool
otherwise = String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
num)
  tday :: Text
tday = Int -> Text
forall a. (Ord a, Num a, Show a) => a -> Text
padd Int
day
  tmonth :: Text
tmonth = Int -> Text
forall a. (Ord a, Num a, Show a) => a -> Text
padd Int
month
  tyear :: Text
tyear = String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
year)
  result :: Text
result
    | Maybe Day -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Day
converted = Text
""
    | DateFormat
format DateFormat -> DateFormat -> Bool
forall a. Eq a => a -> a -> Bool
== DateFormat
FormatDDMMYYYY = Text
tday Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tmonth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tyear
    | DateFormat
format DateFormat -> DateFormat -> Bool
forall a. Eq a => a -> a -> Bool
== DateFormat
FormatMMDDYYYY = Text
tmonth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tday Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tyear
    | Bool
otherwise = Text
tyear Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tmonth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tday

acceptTextInput :: DateFormat -> Char -> Text -> Bool
acceptTextInput :: DateFormat -> Char -> Text -> Bool
acceptTextInput DateFormat
format Char
delim Text
text = Either String Text -> Bool
forall a b. Either a b -> Bool
isRight (Parser Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
A.parseOnly Parser Text
parser Text
text) where
  numP :: Parser Text
numP = Parser Char
A.digit Parser Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
""
  delimP :: Parser Text
delimP = Char -> Parser Char
A.char Char
delim Parser Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
""
  dayP :: Parser Text
dayP = Int -> Parser Text -> Parser Text
P.upto Int
2 Parser Text
numP
  monthP :: Parser Text
monthP = Int -> Parser Text -> Parser Text
P.upto Int
2 Parser Text
numP
  yearP :: Parser Text
yearP = Int -> Parser Text -> Parser Text
P.upto Int
4 Parser Text
numP
  withDelim :: Parser Text a -> Parser Text a
withDelim Parser Text a
parser = a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option a
"" (Parser Text
delimP Parser Text -> Parser Text a -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text a
parser)
  parsers :: [Parser Text]
parsers
    | DateFormat
format DateFormat -> DateFormat -> Bool
forall a. Eq a => a -> a -> Bool
== DateFormat
FormatDDMMYYYY = [Parser Text
dayP, Parser Text -> Parser Text
forall a. IsString a => Parser Text a -> Parser Text a
withDelim Parser Text
monthP, Parser Text -> Parser Text
forall a. IsString a => Parser Text a -> Parser Text a
withDelim Parser Text
yearP]
    | DateFormat
format DateFormat -> DateFormat -> Bool
forall a. Eq a => a -> a -> Bool
== DateFormat
FormatMMDDYYYY = [Parser Text
monthP, Parser Text -> Parser Text
forall a. IsString a => Parser Text a -> Parser Text a
withDelim Parser Text
dayP, Parser Text -> Parser Text
forall a. IsString a => Parser Text a -> Parser Text a
withDelim Parser Text
yearP]
    | Bool
otherwise = [Parser Text
yearP, Parser Text -> Parser Text
forall a. IsString a => Parser Text a -> Parser Text a
withDelim Parser Text
monthP, Parser Text -> Parser Text
forall a. IsString a => Parser Text a -> Parser Text a
withDelim Parser Text
dayP]
  parser :: Parser Text
parser = [Parser Text] -> Parser Text
P.join [Parser Text]
parsers Parser Text -> Parser Text () -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
A.endOfInput

dateInBounds :: (Ord a) => Maybe a -> Maybe a -> a -> Bool
dateInBounds :: Maybe a -> Maybe a -> a -> Bool
dateInBounds Maybe a
Nothing Maybe a
Nothing a
_ = Bool
True
dateInBounds (Just a
minVal) Maybe a
Nothing a
val = a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
minVal
dateInBounds Maybe a
Nothing (Just a
maxVal) a
val = a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
maxVal
dateInBounds (Just a
minVal) (Just a
maxVal) a
val = a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
minVal Bool -> Bool -> Bool
&& a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
maxVal