{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}
module Web.Page.SharedReps
( repInput,
repMessage,
sliderI,
slider,
dropdown,
datalist,
dropdownSum,
colorPicker,
textbox,
textarea,
checkbox,
toggle,
button,
chooseFile,
maybeRep,
fiddle,
viaFiddle,
accordionList,
listMaybeRep,
listRep,
readTextbox,
defaultListLabels,
)
where
import Box.Cont ()
import Control.Lens
import Control.Monad
import Control.Monad.Trans.State
import Data.Attoparsec.Text hiding (take)
import Data.Biapplicative
import Data.Bool
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, pack, unpack)
import Lucid
import Text.InterpolatedString.Perl6
import Web.Page.Bootstrap
import Web.Page.Html
import Web.Page.Html.Input
import Web.Page.Types
import Prelude hiding (lookup)
repInput ::
(Monad m, ToHtml a) =>
Parser a ->
(a -> Text) ->
Input a ->
a ->
SharedRep m a
repInput p pr i a =
SharedRep $ do
name <- zoom _1 genName
zoom _2 (modify (HashMap.insert name (pr a)))
pure $
Rep
(toHtml $ #inputVal .~ a $ #inputId .~ name $ i)
( \s ->
( s,
join
$ maybe (Left "lookup failed") Right
$ either (Left . (\x -> name <> ": " <> x) . pack) Right . parseOnly p <$> HashMap.lookup name s
)
)
repMessage :: (Monad m, ToHtml a) => Parser a -> (a -> Text) -> Input a -> a -> a -> SharedRep m a
repMessage p _ i def a =
SharedRep $ do
name <- zoom _1 genName
pure $
Rep
(toHtml $ #inputVal .~ a $ #inputId .~ name $ i)
( \s ->
( HashMap.delete name s,
join
$ maybe (Right $ Right def) Right
$ either (Left . pack) Right . parseOnly p <$> HashMap.lookup name s
)
)
slider ::
(Monad m) =>
Maybe Text ->
Double ->
Double ->
Double ->
Double ->
SharedRep m Double
slider label l u s v =
repInput
double
(pack . show)
(Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))
v
sliderI ::
(Monad m, ToHtml a, Integral a, Show a) =>
Maybe Text ->
a ->
a ->
a ->
a ->
SharedRep m a
sliderI label l u s v =
repInput
decimal
(pack . show)
(Input v label mempty (Slider [min_ (pack $ show l), max_ (pack $ show u), step_ (pack $ show s)]))
v
textbox :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
textbox label v =
repInput
takeText
id
(Input v label mempty TextBox)
v
textarea :: (Monad m) => Int -> Maybe Text -> Text -> SharedRep m Text
textarea rows label v =
repInput
takeText
id
(Input v label mempty (TextArea rows))
v
colorPicker :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
colorPicker label v =
repInput
takeText
id
(Input v label mempty ColorPicker)
v
dropdown ::
(Monad m, ToHtml a) =>
Parser a ->
(a -> Text) ->
Maybe Text ->
[Text] ->
a ->
SharedRep m a
dropdown p pr label opts v =
repInput
p
pr
(Input v label mempty (Dropdown opts))
v
datalist :: (Monad m) => Maybe Text -> [Text] -> Text -> Text -> SharedRep m Text
datalist label opts v id'' =
repInput
takeText
(pack . show)
(Input v label mempty (Datalist opts id''))
v
dropdownSum ::
(Monad m, ToHtml a) =>
Parser a ->
(a -> Text) ->
Maybe Text ->
[Text] ->
a ->
SharedRep m a
dropdownSum p pr label opts v =
repInput
p
pr
(Input v label mempty (DropdownSum opts))
v
checkbox :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool
checkbox label v =
repInput
((== "true") <$> takeText)
(bool "false" "true")
(Input v label mempty (Checkbox v))
v
toggle :: (Monad m) => Maybe Text -> Bool -> SharedRep m Bool
toggle label v =
repInput
((== "true") <$> takeText)
(bool "false" "true")
(Input v label mempty (Toggle v label))
v
button :: (Monad m) => Maybe Text -> SharedRep m Bool
button label =
repMessage
(pure True)
(bool "false" "true")
(Input False label mempty Button)
False
False
chooseFile :: (Monad m) => Maybe Text -> Text -> SharedRep m Text
chooseFile label v =
repInput
takeText
(pack . show)
(Input v label mempty ChooseFile)
v
checkboxShowJs :: (Monad m) => Maybe Text -> Text -> Bool -> SharedRep m Bool
checkboxShowJs label cl v =
SharedRep $ do
name <- zoom _1 genName
zoom _2 (modify (HashMap.insert name (bool "false" "true" v)))
pure $
Rep
(toHtml (Input v label name (Checkbox v)) <> scriptToggleShow name cl)
( \s ->
( s,
join
$ maybe (Left "HashMap.lookup failed") Right
$ either (Left . pack) Right . parseOnly ((== "true") <$> takeText)
<$> HashMap.lookup name s
)
)
maybeRep ::
(Monad m) =>
Maybe Text ->
Bool ->
SharedRep m a ->
SharedRep m (Maybe a)
maybeRep label st sa = SharedRep $ do
className <- zoom _1 genName
unrep $ bimap (hmap className) mmap (checkboxShowJs label className st) <<*>> sa
where
hmap cl a b =
cardify
(a, [])
Nothing
( ( Lucid.with
div_
[ class__ cl,
style_
("display:" <> bool "none" "block" st)
]
b
),
[style_ "padding-top: 0.25rem; padding-bottom: 0.25rem;"]
)
mmap a b = bool Nothing (Just b) a
accordionList :: (Monad m) => Maybe Text -> Text -> Maybe Text -> (Text -> a -> SharedRep m a) -> [Text] -> [a] -> SharedRep m [a]
accordionList title prefix open srf labels as = SharedRep $ do
(Rep h fa) <-
unrep
$ first (accordion prefix open . zip labels)
$ foldr
(\a x -> bimap (:) (:) a <<*>> x)
(pure [])
(zipWith srf labels as)
h' <- zoom _1 h
pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)
accordionBoolList :: (Monad m) => Maybe Text -> Text -> (a -> SharedRep m a) -> (Bool -> SharedRep m Bool) -> [Text] -> [(Bool, a)] -> SharedRep m [(Bool, a)]
accordionBoolList title prefix bodyf checkf labels xs = SharedRep $ do
(Rep h fa) <-
unrep
$ first (accordionChecked prefix)
$ first (zipWith (\l (ch, a) -> (l, a, ch)) labels)
$ foldr
(\a x -> bimap (:) (:) a <<*>> x)
(pure [])
( ( \(ch, a) ->
( bimap
(,)
(,)
(checkf ch)
<<*>> bodyf a
)
)
<$> xs
)
h' <- zoom _1 h
pure (Rep (maybe mempty (h5_ . toHtml) title <> h') fa)
listMaybeRep :: (Monad m) => Maybe Text -> Text -> (Text -> Maybe a -> SharedRep m (Maybe a)) -> Int -> [a] -> SharedRep m [Maybe a]
listMaybeRep t p srf n as =
accordionList t p Nothing srf (defaultListLabels n) (take n ((Just <$> as) <> repeat Nothing))
listRep ::
(Monad m) =>
Maybe Text ->
Text ->
(Bool -> SharedRep m Bool) ->
(a -> SharedRep m a) ->
Int ->
a ->
[a] ->
SharedRep m [a]
listRep t p brf srf n defa as =
second (mconcat . fmap (\(b, a) -> bool [] [a] b)) $
accordionBoolList
t
p
srf
brf
(defaultListLabels n)
(take n (((True,) <$> as) <> repeat (False, defa)))
defaultListLabels :: Int -> [Text]
defaultListLabels n = (\x -> "[" <> pack (show x) <> "]") <$> [0 .. n] :: [Text]
readTextbox :: (Monad m, Read a, Show a) => Maybe Text -> a -> SharedRep m (Either Text a)
readTextbox label v = parsed . unpack <$> textbox label (pack $ show v)
where
parsed str =
case reads str of
[(a, "")] -> Right a
_ -> Left (pack str)
fiddle :: (Monad m) => Concerns Text -> SharedRep m (Concerns Text, Bool)
fiddle (Concerns c j h) =
bimap
(\c' j' h' up -> (Lucid.with div_ [class__ "fiddle "] $ mconcat [up, h', j', c']))
(\c' j' h' up -> (Concerns c' j' h', up))
(textarea 10 (Just "css") c)
<<*>> textarea 10 (Just "js") j
<<*>> textarea 10 (Just "html") h
<<*>> button (Just "update")
viaFiddle ::
(Monad m) =>
SharedRep m a ->
SharedRep m (Bool, Concerns Text, a)
viaFiddle sr = SharedRep $ do
sr'@(Rep h _) <- unrep sr
hrep <- unrep $ textarea 10 (Just "html") (toText h)
crep <- unrep $ textarea 10 (Just "css") mempty
jrep <- unrep $ textarea 10 (Just "js") mempty
u <- unrep $ button (Just "update")
pure $
bimap
(\up a b c _ -> (Lucid.with div_ [class__ "fiddle "] $ mconcat [up, a, b, c]))
(\up a b c d -> (up, Concerns a b c, d))
u
<<*>> crep
<<*>> jrep
<<*>> hrep
<<*>> sr'
scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()
scriptToggleShow checkName toggleClass =
script_
[qq|
$('#{checkName}').on('change', (function()\{
var vis = this.checked ? "block" : "none";
Array.from(document.getElementsByClassName({toggleClass})).forEach(x => x.style.display = vis);
\}));
|]