{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Glazier.React.Widgets.Input
(
textInput
, checkboxInput
, IndeterminateCheckboxInput(..)
, indeterminateCheckboxInput
) where
import Control.Lens
import Control.Lens.Misc
import qualified Data.Algorithm.Diff as D
import qualified Data.JSString as J
import Data.Tagged
import qualified GHC.Generics as G
import Glazier.React
import Glazier.React.Effect.JavaScript
import Glazier.React.Event.Synthetic
import qualified JavaScript.Extras as JE
type InputChange = Tagged "InputChange"
textInput ::
( AsReactor cmd
, AsJavascript cmd
)
=> ReactId -> Widget cmd p J.JSString (InputChange ())
textInput ri =
let win = do
s <- ask
lf' ri "input"
[ ("key", JE.toJSR ri)
, ("defaultValue", JE.toJSR $ s ^. _model)
]
gad = (finish hdlRendered)
`also` hdlChange
in (display win) `also` (lift gad)
where
hdlRendered ::
( AsReactor cmd
, AsJavascript cmd
)
=> Gadget cmd p J.JSString ()
hdlRendered = onRendered $ do
s <- getModel
j <- getElementalRef ri
(`evalMaybeT` ()) $ do
start <- maybeGetProperty "selectionStart" j
end <- maybeGetProperty "selectionEnd" j
v <- maybeGetProperty "value" j
let (a, b) = estimateSelectionRange (J.unpack v) (J.unpack s) start end
exec' $ SetProperty ("value", JE.toJSR s) j
exec' $ SetProperty ("selectionStart", JE.toJSR a) j
exec' $ SetProperty ("selectionEnd", JE.toJSR b) j
hdlChange ::
( AsReactor cmd
, AsJavascript cmd
)
=> Gadget cmd p J.JSString (InputChange ())
hdlChange = do
j <- trigger ri "onChange" (pure . target . toSyntheticEvent)
maybeDelegate () $ runMaybeT $ do
v <- maybeGetProperty "value" j
tickModel $ id .= v
pure $ Tagged @"InputChange" ()
estimateSelectionRange :: String -> String -> Int -> Int -> (Int, Int)
estimateSelectionRange before after start end =
let ds = D.getDiff before after
in go ds start end 0 0
where
go :: [D.Diff Char] -> Int -> Int -> Int -> Int -> (Int, Int)
go [] _ _ a b = (a, b)
go (d : ds) s e a b =
if (s <= 0 && e <= -1)
then (a, b)
else
let (s', a') = step d s a
(e', b') = greedyStep d e b
in go ds s' e' a' b'
step :: D.Diff Char -> Int -> Int -> (Int, Int)
step (D.First _) s s' = (if s > 0 then s - 1 else 0, s')
step (D.Second _) s s' = (s, if s > 0 then s' + 1 else s')
step (D.Both _ _) s s' = if s > 0
then (s - 1, s' + 1)
else (0, s')
greedyStep :: D.Diff Char -> Int -> Int -> (Int, Int)
greedyStep (D.First _) s s' = (if s >= 0 then s - 1 else (-1), s')
greedyStep (D.Second _) s s' = (s, if s >= 0 then s' + 1 else s')
greedyStep (D.Both _ _) s s' = if s > 0
then (s - 1, s' + 1)
else (-1, s')
checkboxInput ::
(AsReactor cmd)
=> ReactId -> Widget cmd p Bool (InputChange ())
checkboxInput ri =
let win = do
s <- ask
lf' ri "input"
[ ("key", JE.toJSR ri)
, ("type", "checkbox")
, ("checked", JE.toJSR $ s ^. _model)
]
gad = hdlChange
in (display win) `also` (lift gad)
where
hdlChange ::
(AsReactor cmd)
=> Gadget cmd p Bool (InputChange ())
hdlChange = do
trigger_ ri "onChange" ()
tickModel $ id %= not
pure $ Tagged @"InputChange" ()
data IndeterminateCheckboxInput = IndeterminateCheckboxInput
{ checked :: Bool
, indeterminate :: Bool
} deriving (G.Generic, Show, Eq, Ord)
makeLenses_ ''IndeterminateCheckboxInput
indeterminateCheckboxInput ::
( AsReactor cmd
, AsJavascript cmd
)
=> ReactId -> Widget cmd p IndeterminateCheckboxInput (InputChange ())
indeterminateCheckboxInput ri = magnifyWidget _checked (checkboxInput ri)
`also` finish (lift hdlRendered)
where
hdlRendered ::
( AsReactor cmd
, AsJavascript cmd
)
=> Gadget cmd p IndeterminateCheckboxInput ()
hdlRendered = onRendered $ do
j <- getElementalRef ri
s <- getModel
(`evalMaybeT` ()) $ do
i <- MaybeT $ pure $ preview _indeterminate s
exec' $ SetProperty ("indeterminate", JE.toJSR i) j