{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_GHC -Wno-missing-role-annotations #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-partial-fields #-}

module Dashi.Components.Range where

import Clay hiding
    ( Background
    , Color
    , Value
    , action
    , clamp
    , div
    , fullWidth
    , max
    , rem
    , round
    , size
    , type_
    , value
    , var
    )
import Dashi.Prelude hiding (max, none, (#))
import Dashi.Style.Colour
import Dashi.Style.Root (tokenDecl)
import Dashi.Style.Tokens
import Dashi.Style.Uchu (Uchu (..))
import Dashi.Style.Util
import Data.Ord (clamp)
import Miso.CSS (styleInline_)
import Miso.Html.Element (input_)
import Miso.Html.Event qualified as Html
import Miso.Html.Property (max_, min_, step_, type_, value_)

data Background = Background
    deriving stock (Background -> Background -> Bool
(Background -> Background -> Bool)
-> (Background -> Background -> Bool) -> Eq Background
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Background -> Background -> Bool
== :: Background -> Background -> Bool
$c/= :: Background -> Background -> Bool
/= :: Background -> Background -> Bool
Eq, Background
Background -> Background -> Bounded Background
forall a. a -> a -> Bounded a
$cminBound :: Background
minBound :: Background
$cmaxBound :: Background
maxBound :: Background
Bounded, Int -> Background
Background -> Int
Background -> [Background]
Background -> Background
Background -> Background -> [Background]
Background -> Background -> Background -> [Background]
(Background -> Background)
-> (Background -> Background)
-> (Int -> Background)
-> (Background -> Int)
-> (Background -> [Background])
-> (Background -> Background -> [Background])
-> (Background -> Background -> [Background])
-> (Background -> Background -> Background -> [Background])
-> Enum Background
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Background -> Background
succ :: Background -> Background
$cpred :: Background -> Background
pred :: Background -> Background
$ctoEnum :: Int -> Background
toEnum :: Int -> Background
$cfromEnum :: Background -> Int
fromEnum :: Background -> Int
$cenumFrom :: Background -> [Background]
enumFrom :: Background -> [Background]
$cenumFromThen :: Background -> Background -> [Background]
enumFromThen :: Background -> Background -> [Background]
$cenumFromTo :: Background -> Background -> [Background]
enumFromTo :: Background -> Background -> [Background]
$cenumFromThenTo :: Background -> Background -> Background -> [Background]
enumFromThenTo :: Background -> Background -> Background -> [Background]
Enum)

instance Token Background where
    tokenName :: forall s. (IsString s, Semigroup s) => Background -> s
tokenName Background
Background = s
"range-background-color"

instance ValueToken Background where
    type ValueType Background = LightDark Uchu
    tokenValue :: Background -> ValueType Background
tokenValue Background
Background = Uchu -> Uchu -> LightDark Uchu
forall c. c -> c -> LightDark c
LightDark Uchu
Yin2 Uchu
Yin8

data Thumb = Thumb
    deriving stock (Thumb -> Thumb -> Bool
(Thumb -> Thumb -> Bool) -> (Thumb -> Thumb -> Bool) -> Eq Thumb
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Thumb -> Thumb -> Bool
== :: Thumb -> Thumb -> Bool
$c/= :: Thumb -> Thumb -> Bool
/= :: Thumb -> Thumb -> Bool
Eq, Thumb
Thumb -> Thumb -> Bounded Thumb
forall a. a -> a -> Bounded a
$cminBound :: Thumb
minBound :: Thumb
$cmaxBound :: Thumb
maxBound :: Thumb
Bounded, Int -> Thumb
Thumb -> Int
Thumb -> [Thumb]
Thumb -> Thumb
Thumb -> Thumb -> [Thumb]
Thumb -> Thumb -> Thumb -> [Thumb]
(Thumb -> Thumb)
-> (Thumb -> Thumb)
-> (Int -> Thumb)
-> (Thumb -> Int)
-> (Thumb -> [Thumb])
-> (Thumb -> Thumb -> [Thumb])
-> (Thumb -> Thumb -> [Thumb])
-> (Thumb -> Thumb -> Thumb -> [Thumb])
-> Enum Thumb
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Thumb -> Thumb
succ :: Thumb -> Thumb
$cpred :: Thumb -> Thumb
pred :: Thumb -> Thumb
$ctoEnum :: Int -> Thumb
toEnum :: Int -> Thumb
$cfromEnum :: Thumb -> Int
fromEnum :: Thumb -> Int
$cenumFrom :: Thumb -> [Thumb]
enumFrom :: Thumb -> [Thumb]
$cenumFromThen :: Thumb -> Thumb -> [Thumb]
enumFromThen :: Thumb -> Thumb -> [Thumb]
$cenumFromTo :: Thumb -> Thumb -> [Thumb]
enumFromTo :: Thumb -> Thumb -> [Thumb]
$cenumFromThenTo :: Thumb -> Thumb -> Thumb -> [Thumb]
enumFromThenTo :: Thumb -> Thumb -> Thumb -> [Thumb]
Enum)

instance Token Thumb where
    tokenName :: forall s. (IsString s, Semigroup s) => Thumb -> s
tokenName Thumb
Thumb = s
"range-thumb-color"

instance ValueToken Thumb where
    type ValueType Thumb = LightDark Uchu
    tokenValue :: Thumb -> ValueType Thumb
tokenValue Thumb
Thumb = Uchu -> Uchu -> LightDark Uchu
forall c. c -> c -> LightDark c
LightDark Uchu
Yin9 Uchu
Yin1

data Progress = Progress
    deriving stock (Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
/= :: Progress -> Progress -> Bool
Eq, Progress
Progress -> Progress -> Bounded Progress
forall a. a -> a -> Bounded a
$cminBound :: Progress
minBound :: Progress
$cmaxBound :: Progress
maxBound :: Progress
Bounded, Int -> Progress
Progress -> Int
Progress -> [Progress]
Progress -> Progress
Progress -> Progress -> [Progress]
Progress -> Progress -> Progress -> [Progress]
(Progress -> Progress)
-> (Progress -> Progress)
-> (Int -> Progress)
-> (Progress -> Int)
-> (Progress -> [Progress])
-> (Progress -> Progress -> [Progress])
-> (Progress -> Progress -> [Progress])
-> (Progress -> Progress -> Progress -> [Progress])
-> Enum Progress
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Progress -> Progress
succ :: Progress -> Progress
$cpred :: Progress -> Progress
pred :: Progress -> Progress
$ctoEnum :: Int -> Progress
toEnum :: Int -> Progress
$cfromEnum :: Progress -> Int
fromEnum :: Progress -> Int
$cenumFrom :: Progress -> [Progress]
enumFrom :: Progress -> [Progress]
$cenumFromThen :: Progress -> Progress -> [Progress]
enumFromThen :: Progress -> Progress -> [Progress]
$cenumFromTo :: Progress -> Progress -> [Progress]
enumFromTo :: Progress -> Progress -> [Progress]
$cenumFromThenTo :: Progress -> Progress -> Progress -> [Progress]
enumFromThenTo :: Progress -> Progress -> Progress -> [Progress]
Enum)

instance Token Progress where
    tokenName :: forall s. (IsString s, Semigroup s) => Progress -> s
tokenName Progress
Progress = s
"range-progress-color"

instance ValueToken Progress where
    type ValueType Progress = LightDark Uchu
    tokenValue :: Progress -> ValueType Progress
tokenValue Progress
Progress = Uchu -> Uchu -> LightDark Uchu
forall c. c -> c -> LightDark c
LightDark Uchu
Yin6 Uchu
Yin4

data Range action = Range
    { forall action. Range action -> Int
value :: Int
    , forall action. Range action -> Int
step :: Int
    , forall action. Range action -> Int
min :: Int
    , forall action. Range action -> Int
max :: Int
    , forall action. Range action -> Int -> action
onChange :: Int -> action
    }

instance Widget (Range action) model action where
    widget' :: [Attribute action] -> Range action -> View model action
widget' [Attribute action]
attrs Range{Int
Int -> action
value :: forall action. Range action -> Int
step :: forall action. Range action -> Int
min :: forall action. Range action -> Int
max :: forall action. Range action -> Int
onChange :: forall action. Range action -> Int -> action
value :: Int
step :: Int
min :: Int
max :: Int
onChange :: Int -> action
..} =
        [Attribute action] -> View model action
forall action model. [Attribute action] -> View model action
input_
            ([Attribute action] -> View model action)
-> [Attribute action] -> View model action
forall a b. (a -> b) -> a -> b
$ MisoString -> Attribute action
forall action. MisoString -> Attribute action
type_ MisoString
"range"
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: MisoString -> Attribute action
forall action. MisoString -> Attribute action
min_ (Int -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString Int
roundedDownMinValue)
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: MisoString -> Attribute action
forall action. MisoString -> Attribute action
max_ (Int -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString Int
roundedUpMaxValue)
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: MisoString -> Attribute action
forall action. MisoString -> Attribute action
step_ (Int -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString Int
step)
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: MisoString -> Attribute action
forall action. MisoString -> Attribute action
value_ (Int -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString Int
displayValue)
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: MisoString -> Attribute action
forall action. MisoString -> Attribute action
styleInline_ (MisoString
"--progress:" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Milli -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString Milli
roundedPercentage MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"%")
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: (MisoString -> action) -> Attribute action
forall action. (MisoString -> action) -> Attribute action
Html.onInput (Int -> action
onChange (Int -> action) -> (MisoString -> Int) -> MisoString -> action
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Int, Int) -> Int -> Int
forall a. Ord a => (a, a) -> a -> a
clamp (Int
min, Int
max) (Int -> Int) -> (MisoString -> Int) -> MisoString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. MisoString -> Int
forall a. FromMisoString a => MisoString -> a
fromMisoString)
            Attribute action -> [Attribute action] -> [Attribute action]
forall a. a -> [a] -> [a]
: [Attribute action]
attrs
      where
        roundedDownMinValue :: Int
roundedDownMinValue
            | Int
min Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
step Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
min
            | Bool
otherwise = (Int
min Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step

        roundedUpMaxValue :: Int
roundedUpMaxValue
            | Int
max Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
step Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
max
            | Bool
otherwise = (Int
max Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step

        displayValue :: Int
displayValue =
            let maxSliderValue :: Int
maxSliderValue = (Int
max Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
step) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step
                minSliderValue :: Int
minSliderValue = forall a b. (RealFrac a, Integral b) => a -> b
ceiling @Milli (Int -> Milli
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
min Milli -> Milli -> Milli
forall a. Fractional a => a -> a -> a
/ Int -> Milli
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
step) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step
             in if Int
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minSliderValue
                    then Int
roundedDownMinValue
                    else
                        if Int
value Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxSliderValue
                            then Int
roundedUpMaxValue
                            else Int
value
        roundedPercentage :: Milli
roundedPercentage
            | Int
min Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
max = Milli
0 :: Milli
            | Bool
otherwise =
                let range :: Int
range = Int
roundedUpMaxValue Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
roundedDownMinValue
                    relativeValue :: Int
relativeValue = Int
displayValue Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
roundedDownMinValue
                    numSteps :: Int
numSteps = forall a b. (RealFrac a, Integral b) => a -> b
round @Milli (Milli -> Int) -> Milli -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Milli
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
relativeValue Milli -> Milli -> Milli
forall a. Fractional a => a -> a -> a
/ Int -> Milli
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
step
                 in Int -> Milli
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
numSteps Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step) Milli -> Milli -> Milli
forall a. Fractional a => a -> a -> a
/ Int -> Milli
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
range Milli -> Milli -> Milli
forall a. Num a => a -> a -> a
* Milli
100
    style :: Css
style = do
        Selector
":root" Selector -> Css -> Css
? do
            forall t. (ValueToken t, Val (ValueType t)) => Css
tokenDecl @Background
            forall t. (ValueToken t, Val (ValueType t)) => Css
tokenDecl @Progress
            forall t. (ValueToken t, Val (ValueType t)) => Css
tokenDecl @Thumb
        Selector
input Selector -> Refinement -> Selector
# (MisoString
"type" MisoString -> MisoString -> Refinement
@= MisoString
"range") Selector -> Css -> Css
? do
            SizeToken -> Css
borderRadiusAll' SizeToken
Large
            Background -> Css
forall t. Token t => t -> Css
backgroundColor' Background
Background
            Key MisoString
"accent-color" Key MisoString -> Color -> Css
forall v. Val v => Key MisoString -> v -> Css
~:: Thumb -> Color
forall t. Token t => t -> Color
colorToken Thumb
Thumb
            Size LengthUnit -> Css
forall a. Size a -> Css
height (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Number -> Size LengthUnit
em Number
0.5
            Progress -> Css
forall t. Token t => t -> Css
color' Progress
Progress
            CursorValue Value -> Css
forall a. Cursor a => a -> Css
cursor CursorValue Value
ewResize
            Key MisoString
"background-image"
                Key MisoString -> MisoString -> Css
-: MisoString
"linear-gradient(to right, currentColor var(--progress), transparent var(--progress))"
        NonEmpty Selector -> Selector
forall a. Semigroup a => NonEmpty a -> a
sconcat
            ( (Selector
input Selector -> Refinement -> Selector
# (MisoString
"type" MisoString -> MisoString -> Refinement
@= MisoString
"range") Selector -> Refinement -> Selector
#)
                (Refinement -> Selector)
-> NonEmpty Refinement -> NonEmpty Selector
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item (NonEmpty Refinement)
Refinement
"::-moz-range-thumb", Item (NonEmpty Refinement)
Refinement
"::-webkit-slider-thumb"]
            )
            Selector -> Css -> Css
? do
                Key MisoString
"-moz-appearance" Key MisoString -> Value -> Css
~: Value
forall a. None a => a
none
                Key MisoString
"-webkit-appearance" Key MisoString -> Value -> Css
~: Value
forall a. None a => a
none
                Size LengthUnit -> Css
forall a. Size a -> Css
width (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Number -> Size LengthUnit
em Number
1
                Size LengthUnit -> Css
forall a. Size a -> Css
height (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Number -> Size LengthUnit
em Number
1
                SizeToken -> Css
borderRadiusAll' SizeToken
Large
                Thumb -> Css
forall t. Token t => t -> Css
backgroundColor' Thumb
Thumb
                Size LengthUnit -> Css
forall a. Size a -> Css
marginTop (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Number -> Size LengthUnit
em Number
0.03
                Size LengthUnit -> Css
borderWidth Size LengthUnit
forall a. Size a
nil