{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wall #-}
module Web.Suavemente.Input where
import Control.Arrow ((&&&))
import Control.Concurrent.STM.TVar (newTVar, readTVar)
import Control.Monad.State.Class (MonadState (..), modify)
import Control.Monad.Trans.Class (lift)
import Data.Aeson (FromJSON (..), Value, withText)
import Data.Aeson.Types (Parser)
import Data.Bool (bool)
import Data.Colour.SRGB (Colour, sRGB24show, sRGB24read)
import Data.Text (unpack)
import Text.Blaze (preEscapedString, Markup, ToMarkup (..))
import Text.InterpolatedString.Perl6 (qc, q)
import Web.Suavemente.Core
import Web.Suavemente.Types
genName :: MonadState Int m => m String
genName = do
s <- get
modify (+1)
pure $ show s
mkInput
:: (Value -> Parser a)
-> (String -> a -> Markup)
-> a
-> Suave a
mkInput p f a = Suave $ do
name <- genName
tvar <- lift $ newTVar a
pure $ Input (f name a) (getEvents p tvar name) (readTVar tvar)
slider
:: (ToMarkup a, Num a, FromJSON a)
=> String
-> a
-> a
-> a
-> Suave a
slider label l u = mkInput parseJSON $ \name v ->
preEscapedString
[qc|<tr><td>
<label for="{name}">{label}</label>
</td><td>
<input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" value="{showMarkup v}" autocomplete="off">
</td></tr>|]
realSlider
:: (ToMarkup a, Num a, Real a, FromJSON a)
=> String
-> a
-> a
-> a
-> a
-> Suave a
realSlider label l u s = mkInput parseJSON $ \name v ->
preEscapedString
[qc|<tr><td>
<label for="{name}">{label}</label>
</td><td>
<input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" step="{showMarkup s}" value="{showMarkup v}" autocomplete="off">
</td></tr>|]
colorPicker
:: (Ord a, Floating a, RealFrac a)
=> String
-> Colour a
-> Suave (Colour a)
colorPicker label =
mkInput
(withText "hex colour representation" (pure . sRGB24read . unpack)) $
\name v ->
preEscapedString
[qc|<tr><td>
<label for="{name}">{label}</label>
</td><td>
<input id="{name}" oninput="onChangeFunc(event)" type="color" value="{sRGB24show v}">
</td></tr>|]
checkbox :: String -> Bool -> Suave Bool
checkbox label = mkInput parseJSON $ \name v ->
preEscapedString
[qc|<tr><td>
<label for="{name}">{label}</label>
</td><td>
<input id="{name}" onchange="onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">
</td></tr>|]
checkbox_ :: String -> Bool -> Suave Bool
checkbox_ label = mkInput parseJSON $ \name v ->
preEscapedString
[qc|
<label for="{name}">{label}</label>
<input id="{name}" onchange="onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">
|]
textbox
:: String
-> String
-> Suave String
textbox label = mkInput parseJSON $ \name v ->
preEscapedString
[qc|<tr><td>
<label for="{name}">{label}</label>
</td><td>
<input id="{name}" oninput="onChangeFunc(event)" type="text" value="{v}" autocomplete="off">
</td></tr>|]
textbox_
:: String
-> String
-> Suave String
textbox_ label = mkInput parseJSON $ \name v ->
preEscapedString
[qc|
<label for="{name}">{label}</label>
<input id="{name}" oninput="onChangeFunc(event)" type="text" value="{v}" autocomplete="off">
|]
dropdown
:: (FromJSON a, ToMarkup a, Eq a)
=> String
-> [(String, a)]
-> a
-> Suave a
dropdown label opts = mkInput parseJSON $ \name d -> preEscapedString $
mconcat $
[ [qc|<tr><td><label for="{name}">{label}</label></td><td>|]
, [qc|<select id="{name}" onchange="onChangeFunc(event)" autocomplete="off">|]
] ++
fmap
(\(oname, oval) -> [qc|<option {if oval == d then "selected" else ""} value="{showMarkup oval}" >{oname}</option>|])
opts
++
[ [q|</select>|]
, [q|</td></tr>|]
]
enumDropdown
:: (FromJSON a, ToMarkup a, Enum a, Bounded a, Eq a)
=> String
-> a
-> Suave a
enumDropdown label =
dropdown label $ fmap (showMarkup &&& id) [minBound .. maxBound]
checkboxShow :: String -> String -> Bool -> Suave Bool
checkboxShow label cl =
mkInput parseJSON $ \name v ->
preEscapedString (showJs cl) <>
preEscapedString [qc|
<label for="{name}">{label}</label>
<input id="{name}" onchange="showJs('{cl}','{name}');onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">
|]
showJs :: String -> String
showJs cl =
[qc|
<script>
function showJs (cl, box) \{
var vis = (document.getElementById(box).checked) ? "block" : "none";
Array.from(document.getElementsByClassName("{cl}")).forEach(x => x.style.display = vis);
};
</script>
|]
markupF :: (Markup -> Markup) -> Suave a -> Suave a
markupF f (Suave sa) = Suave $ do
Input markup s v <- sa
pure $ Input (f markup) s v
div' :: String -> String -> Suave a -> Suave a
div' cl st = markupF (\x ->
preEscapedString [qc|<div class="{cl}" style="{st}">|] <>
x <>
preEscapedString "</div>")
display :: Bool -> String
display b = "display:" ++ bool "none" "block" b
toggleInput :: String -> Bool -> String -> Suave a -> Suave (Bool, a)
toggleInput label start cl sa = do
a <- div' cl (display start) sa
c <- checkboxShow label cl start
pure (c,a)