{-# LANGUAGE OverloadedStrings #-}
module NanoUI.Widgets.NumericInput
( NumericInputConfig (..)
, defaultNumericInputConfig
, numericInput
, numericInput'
, numericInputConfigured
, numericInputConfigured'
)
where
import Control.Monad (when)
import Data.Char (isDigit, isHexDigit)
import Data.IntMap.Strict qualified as IM
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Read qualified as TR
import Effectful (Eff, type (:>))
import GHC.Clock (getMonotonicTime)
import NanoUI.Context (getStore, intKey, markDirty, registerFocusable, modifyStore)
import NanoUI.Input (Key (..), inputKeys, inputKeysElem, inputModifiers, inputMouseDown, inputMousePos, inputMousePressed, modShift)
import NanoUI.Layout.Arena (NodeType (..))
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)
import NanoUI.Store (WidgetStore (..), slotKey, Slot (..))
import NanoUI.Style (Layout (..), Sizing (..), defaultLayout)
import NanoUI.Types (Rect (..), rectContains)
import NanoUI.WidgetText (numericStepperRects, textInputFlagNumeric)
import NanoUI.Widgets.Behavior (keyboardFocused)
import NanoUI.Widgets.Node (Response, addWidgetStyled, respHovered, respRect, setChanged, setSubmitted)
import NanoUI.Widgets.TextEditor (singleLineMode)
import NanoUI.Widgets.TextInput (TextInputState (..), editTextInput, editorTextState, loadTextInputState, saveTextEditor, saveTextInputState)
import Numeric (showFFloat, showHex)
data NumericInputConfig = NumericInputConfig
{ NumericInputConfig -> Double
nicMin :: !Double
, NumericInputConfig -> Double
nicMax :: !Double
, NumericInputConfig -> Double
nicStep :: !Double
, NumericInputConfig -> Int
nicDecimals :: !Int
, NumericInputConfig -> Bool
nicHex :: !Bool
, NumericInputConfig -> Layout
nicLayout :: !Layout
}
deriving (NumericInputConfig -> NumericInputConfig -> Bool
(NumericInputConfig -> NumericInputConfig -> Bool)
-> (NumericInputConfig -> NumericInputConfig -> Bool)
-> Eq NumericInputConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumericInputConfig -> NumericInputConfig -> Bool
== :: NumericInputConfig -> NumericInputConfig -> Bool
$c/= :: NumericInputConfig -> NumericInputConfig -> Bool
/= :: NumericInputConfig -> NumericInputConfig -> Bool
Eq, Int -> NumericInputConfig -> ShowS
[NumericInputConfig] -> ShowS
NumericInputConfig -> String
(Int -> NumericInputConfig -> ShowS)
-> (NumericInputConfig -> String)
-> ([NumericInputConfig] -> ShowS)
-> Show NumericInputConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumericInputConfig -> ShowS
showsPrec :: Int -> NumericInputConfig -> ShowS
$cshow :: NumericInputConfig -> String
show :: NumericInputConfig -> String
$cshowList :: [NumericInputConfig] -> ShowS
showList :: [NumericInputConfig] -> ShowS
Show)
defaultNumericInputConfig :: NumericInputConfig
defaultNumericInputConfig :: NumericInputConfig
defaultNumericInputConfig =
NumericInputConfig
{ nicMin :: Double
nicMin = -Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0
, nicMax :: Double
nicMax = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0
, nicStep :: Double
nicStep = Double
1
, nicDecimals :: Int
nicDecimals = Int
0
, nicHex :: Bool
nicHex = Bool
False
, nicLayout :: Layout
nicLayout = Layout
defaultLayout {layoutWidth = Grow 1, layoutMinW = 80}
}
{-# INLINE numericInput #-}
numericInput :: Ui :> es => Double -> Eff es Double
numericInput :: forall (es :: [Effect]). (Ui :> es) => Double -> Eff es Double
numericInput Double
value = (Response, Double) -> Double
forall a b. (a, b) -> b
snd ((Response, Double) -> Double)
-> Eff es (Response, Double) -> Eff es Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumericInputConfig -> Double -> Eff es (Response, Double)
forall (es :: [Effect]).
(Ui :> es) =>
NumericInputConfig -> Double -> Eff es (Response, Double)
numericInputConfigured' NumericInputConfig
defaultNumericInputConfig Double
value
{-# INLINE numericInput' #-}
numericInput' :: Ui :> es => Double -> Eff es (Response, Double)
numericInput' :: forall (es :: [Effect]).
(Ui :> es) =>
Double -> Eff es (Response, Double)
numericInput' = NumericInputConfig -> Double -> Eff es (Response, Double)
forall (es :: [Effect]).
(Ui :> es) =>
NumericInputConfig -> Double -> Eff es (Response, Double)
numericInputConfigured' NumericInputConfig
defaultNumericInputConfig
{-# INLINE numericInputConfigured #-}
numericInputConfigured :: Ui :> es => NumericInputConfig -> Double -> Eff es Double
numericInputConfigured :: forall (es :: [Effect]).
(Ui :> es) =>
NumericInputConfig -> Double -> Eff es Double
numericInputConfigured NumericInputConfig
cfg Double
value = (Response, Double) -> Double
forall a b. (a, b) -> b
snd ((Response, Double) -> Double)
-> Eff es (Response, Double) -> Eff es Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NumericInputConfig -> Double -> Eff es (Response, Double)
forall (es :: [Effect]).
(Ui :> es) =>
NumericInputConfig -> Double -> Eff es (Response, Double)
numericInputConfigured' NumericInputConfig
cfg Double
value
numericInputConfigured' :: Ui :> es => NumericInputConfig -> Double -> Eff es (Response, Double)
numericInputConfigured' :: forall (es :: [Effect]).
(Ui :> es) =>
NumericInputConfig -> Double -> Eff es (Response, Double)
numericInputConfigured' NumericInputConfig
cfg Double
value = do
wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
ctx <- askContext
inp <- askInput
uiIO $ registerFocusable ctx wid
store <- uiIO (getStore ctx)
isFocus <- keyboardFocused wid
let
key = WidgetId -> Int
intKey WidgetId
wid
given = NumericInputConfig -> Double -> Double
clampNumber NumericInputConfig
cfg Double
value
stored = Int -> IntMap Text -> Maybe Text
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
text0 = if Bool
isFocus then Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (NumericInputConfig -> Double -> Text
formatNumber NumericInputConfig
cfg Double
given) Maybe Text
stored else NumericInputConfig -> Double -> Text
formatNumber NumericInputConfig
cfg Double
given
s0 = WidgetStore -> Int -> Text -> TextInputState
loadTextInputState WidgetStore
store Int
key Text
text0
lastValue = Double -> Int -> IntMap Double -> Double
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Double
given Int
key (WidgetStore -> IntMap Double
storeDouble WidgetStore
store)
mEdited <- if isFocus then uiIO (editTextInput ctx singleLineMode inp store key s0) else pure Nothing
resp <- addWidgetStyled wid NodeTextInput "" 0 (nicLayout cfg) textInputFlagNumeric
let
typed = TextInputState
-> (Editor -> TextInputState) -> Maybe Editor -> TextInputState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TextInputState
s0 Editor -> TextInputState
editorTextState Maybe Editor
mEdited
s1 = if NumericInputConfig -> Text -> Bool
acceptsNumberText NumericInputConfig
cfg (TextInputState -> Text
tisText TextInputState
typed) then TextInputState
typed else TextInputState
s0
current
| Bool
isFocus = Double -> (Double -> Double) -> Maybe Double -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
lastValue (NumericInputConfig -> Double -> Double
clampNumber NumericInputConfig
cfg) (NumericInputConfig -> Text -> Maybe Double
parseNumber NumericInputConfig
cfg (TextInputState -> Text
tisText TextInputState
s1))
| Bool
otherwise = Double
given
Rect rx ry rw rh = respRect resp
(upRect, downRect) = numericStepperRects rx ry rw rh
mouse = Input -> V2
inputMousePos Input
inp
keys = Input -> SmallArray Key
inputKeys Input
inp
over Rect
r Int
dir = if Response -> Bool
forall r. HasResponse r => r -> Bool
respHovered Response
resp Bool -> Bool -> Bool
&& Rect -> V2 -> Bool
rectContains Rect
r V2
mouse then Int
dir else Int
0
pressDir
| Input -> Bool
inputMousePressed Input
inp = Rect -> Int -> Int
over Rect
upRect Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Rect -> Int -> Int
over Rect
downRect (-Int
1)
| Bool
otherwise = Int
0 :: Int
held0 = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotNumericHeld Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
holding =
Int
held0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
Bool -> Bool -> Bool
&& Input -> Bool
inputMouseDown Input
inp
Bool -> Bool -> Bool
&& Rect -> Int -> Int
over (if Int
held0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Rect
upRect else Rect
downRect) Int
held0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
keyDir
| Bool -> Bool
not Bool
isFocus = Int
0
| Key -> SmallArray Key -> Bool
inputKeysElem Key
KeyUp SmallArray Key
keys = Int
1
| Key -> SmallArray Key -> Bool
inputKeysElem Key
KeyDown SmallArray Key
keys = -Int
1
| Bool
otherwise = Int
0
now <- if pressDir /= 0 || holding then uiIO getMonotonicTime else pure 0
let
repeatAt0 = Double -> Int -> IntMap Double -> Double
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Double
0 (Slot -> Int -> Int
slotKey Slot
SlotNumericRepeat Int
key) (WidgetStore -> IntMap Double
storeDouble WidgetStore
store)
repeatDir = if Int
pressDir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
holding Bool -> Bool -> Bool
&& Double
now Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
repeatAt0 then Int
held0 else Int
0
dir
| Int
pressDir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
pressDir
| Int
repeatDir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
repeatDir
| Bool
otherwise = Int
keyDir
held1
| Int
pressDir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
pressDir
| Bool
holding = Int
held0
| Bool
otherwise = Int
0
repeatAt1
| Int
pressDir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.4
| Int
repeatDir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.06
| Int
held1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Double
0
| Bool
otherwise = Double
repeatAt0
scale = if Modifiers -> Bool
modShift (Input -> Modifiers
inputModifiers Input
inp) then Double
10 else Double
1
final
| Int
dir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = NumericInputConfig -> Double -> Double
clampNumber NumericInputConfig
cfg (NumericInputConfig -> Double -> Double
roundNumber NumericInputConfig
cfg (Double
current Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dir Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale Double -> Double -> Double
forall a. Num a => a -> a -> a
* NumericInputConfig -> Double
nicStep NumericInputConfig
cfg))
| Bool
otherwise = Double
current
submitted = Bool
isFocus Bool -> Bool -> Bool
&& Key -> SmallArray Key -> Bool
inputKeysElem Key
KeyEnter SmallArray Key
keys
s2
| Int
dir Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| Bool
submitted =
let t :: Text
t = NumericInputConfig -> Double -> Text
formatNumber NumericInputConfig
cfg Double
final
in Text -> Int -> Int -> TextInputState
TextInputState Text
t (Text -> Int
T.length Text
t) (Text -> Int
T.length Text
t)
| Bool
otherwise = TextInputState
s1
heldK = Slot -> Int -> Int
slotKey Slot
SlotNumericHeld Int
key
repeatK = Slot -> Int -> Int
slotKey Slot
SlotNumericRepeat Int
key
dirty =
Maybe Text
stored Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just (TextInputState -> Text
tisText TextInputState
s2)
Bool -> Bool -> Bool
|| TextInputState
s2 TextInputState -> TextInputState -> Bool
forall a. Eq a => a -> a -> Bool
/= TextInputState
s0
Bool -> Bool -> Bool
|| Int -> IntMap Double -> Maybe Double
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
key (WidgetStore -> IntMap Double
storeDouble WidgetStore
store) Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Maybe Double
forall a. a -> Maybe a
Just Double
final
Bool -> Bool -> Bool
|| Int
held1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
held0
Bool -> Bool -> Bool
|| Double
repeatAt1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
repeatAt0
when dirty $
uiIO $ do
let save = case Maybe Editor
mEdited of
Just Editor
ed | Editor -> TextInputState
editorTextState Editor
ed TextInputState -> TextInputState -> Bool
forall a. Eq a => a -> a -> Bool
== TextInputState
s2 -> Int -> Editor -> WidgetStore -> WidgetStore
saveTextEditor Int
key Editor
ed
Maybe Editor
_ -> Int -> TextInputState -> WidgetStore -> WidgetStore
saveTextInputState Int
key TextInputState
s2
modifyStore ctx $ \WidgetStore
st0 ->
let st :: WidgetStore
st = WidgetStore -> WidgetStore
save WidgetStore
st0
in WidgetStore
st
{ storeInt = (if held1 == 0 then IM.delete heldK else IM.insert heldK held1) (storeInt st)
, storeDouble = IM.insert key final (IM.insert repeatK repeatAt1 (storeDouble st))
}
when (held1 /= 0) $ uiIO (markDirty ctx)
pure (setSubmitted submitted (setChanged (final /= value) resp), final)
clampNumber :: NumericInputConfig -> Double -> Double
clampNumber :: NumericInputConfig -> Double -> Double
clampNumber NumericInputConfig
cfg = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (NumericInputConfig -> Double
nicMin NumericInputConfig
cfg) (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (NumericInputConfig -> Double
nicMax NumericInputConfig
cfg)
roundNumber :: NumericInputConfig -> Double -> Double
roundNumber :: NumericInputConfig -> Double -> Double
roundNumber NumericInputConfig
cfg Double
v
| NumericInputConfig -> Bool
nicHex NumericInputConfig
cfg Bool -> Bool -> Bool
|| NumericInputConfig -> Int
nicDecimals NumericInputConfig
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
v)
| Bool
otherwise = Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
scale)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
scale
where
scale :: Double
scale = Double
10 Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ NumericInputConfig -> Int
nicDecimals NumericInputConfig
cfg
formatNumber :: NumericInputConfig -> Double -> Text
formatNumber :: NumericInputConfig -> Double -> Text
formatNumber NumericInputConfig
cfg Double
v
| NumericInputConfig -> Bool
nicHex NumericInputConfig
cfg =
let n :: Integer
n = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
v :: Integer
in (if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Text
"-" else Text
"") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (String -> Text
T.pack (Integer -> ShowS
forall a. Integral a => a -> ShowS
showHex (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n) String
""))
| NumericInputConfig -> Int
nicDecimals NumericInputConfig
cfg Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
v :: Integer))
| Bool
otherwise = String -> Text
T.pack (Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just (NumericInputConfig -> Int
nicDecimals NumericInputConfig
cfg)) Double
v String
"")
acceptsNumberText :: NumericInputConfig -> Text -> Bool
acceptsNumberText :: NumericInputConfig -> Text -> Bool
acceptsNumberText NumericInputConfig
cfg Text
t =
Bool
signOk Bool -> Bool -> Bool
&& case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
body of
[Text
whole] -> (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
digit Text
whole
[Text
whole, Text
frac] -> Int
decimals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
whole Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
frac Bool -> Bool -> Bool
&& Text -> Int
T.length Text
frac Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
decimals
[Text]
_ -> Bool
False
where
(Bool
negative, Text
body) = (Bool, Text)
-> (Text -> (Bool, Text)) -> Maybe Text -> (Bool, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, Text
t) ((,) Bool
True) (Text -> Text -> Maybe Text
T.stripPrefix Text
"-" Text
t)
signOk :: Bool
signOk = Bool -> Bool
not Bool
negative Bool -> Bool -> Bool
|| NumericInputConfig -> Double
nicMin NumericInputConfig
cfg Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0
digit :: Char -> Bool
digit = if NumericInputConfig -> Bool
nicHex NumericInputConfig
cfg then Char -> Bool
isHexDigit else Char -> Bool
isDigit
decimals :: Int
decimals = if NumericInputConfig -> Bool
nicHex NumericInputConfig
cfg then Int
0 else NumericInputConfig -> Int
nicDecimals NumericInputConfig
cfg
parseNumber :: NumericInputConfig -> Text -> Maybe Double
parseNumber :: NumericInputConfig -> Text -> Maybe Double
parseNumber NumericInputConfig
cfg Text
t
| NumericInputConfig -> Bool
nicHex NumericInputConfig
cfg = case Reader Integer -> Reader Integer
forall a. Num a => Reader a -> Reader a
TR.signed Reader Integer
forall a. Integral a => Reader a
TR.hexadecimal Text
t of
Right (Integer
n, Text
rest) | Text -> Bool
T.null Text
rest -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
n)
Either String (Integer, Text)
_ -> Maybe Double
forall a. Maybe a
Nothing
| Bool
otherwise = case Reader Double -> Reader Double
forall a. Num a => Reader a -> Reader a
TR.signed Reader Double
forall a. Fractional a => Reader a
TR.rational ((Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
t) of
Right (Double
v, Text
rest) | Text -> Bool
T.null Text
rest -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
v
Either String (Double, Text)
_ -> Maybe Double
forall a. Maybe a
Nothing