{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}
module Web.Rep.SharedReps
( repInput,
repMessage,
sliderI,
slider,
dropdown,
dropdownMultiple,
datalist,
dropdownSum,
colorPicker,
textbox,
textarea,
checkbox,
toggle,
button,
chooseFile,
maybeRep,
fiddle,
viaFiddle,
accordionList,
listMaybeRep,
listRep,
readTextbox,
defaultListLabels,
repChoice,
subtype,
selectItems,
repItemsSelect,
)
where
import Box.Cont ()
import Control.Lens
import Data.Attoparsec.Text hiding (take)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import Data.Text (intercalate)
import Lucid
import NumHask.Prelude hiding (intercalate, takeWhile)
import Text.InterpolatedString.Perl6
import Web.Rep.Bootstrap
import Web.Rep.Html
import Web.Rep.Html.Input
import Web.Rep.Shared
import Web.Rep.Page
import qualified Prelude as P
import qualified Data.Attoparsec.Text as A
repInput ::
(Monad m, ToHtml a) =>
Parser a ->
(a -> Text) ->
Input a ->
a ->
SharedRep m a
repInput p pr i a =
register (first pack . A.parseOnly p) pr (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a
repMessage :: (Monad m, ToHtml a) => Parser a -> (a -> Text) -> Input a -> a -> a -> SharedRep m a
repMessage p _ i def a =
message (first pack . A.parseOnly p) (\n v -> toHtml $ #inputVal .~ v $ #inputId .~ n $ i) a def
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, P.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
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
dropdownMultiple ::
(Monad m, ToHtml a) =>
Parser a ->
(a -> Text) ->
Maybe Text ->
[Text] ->
[a] ->
SharedRep m [a]
dropdownMultiple p pr label opts vs =
repInput
(p `sepBy1` char ',')
(intercalate "," . fmap pr)
(Input vs label mempty (DropdownMultiple opts ','))
vs
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
maybeRep ::
(Monad m) =>
Maybe Text ->
Bool ->
SharedRep m a ->
SharedRep m (Maybe a)
maybeRep label st sa = SharedRep $ do
id' <- zoom _1 (genNamePre "maybe")
unshare $ bimap (hmap id') mmap (checkboxShow label id' st) <<*>> sa
where
hmap id' a b =
cardify
(a, [])
Nothing
( Lucid.with
div_
[ id_ id',
style_
("display:" <> bool "none" "block" st)
]
b,
[style_ "padding-top: 0.25rem; padding-bottom: 0.25rem;"]
)
mmap a b = bool Nothing (Just b) a
checkboxShow :: (Monad m) => Maybe Text -> Text -> Bool -> SharedRep m Bool
checkboxShow label id' 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 id')
( \s ->
( s,
join
$ maybe (Left "HashMap.lookup failed") Right
$ either (Left . pack) Right . parseOnly ((== "true") <$> takeText)
<$> HashMap.lookup name s
)
)
scriptToggleShow :: (Monad m) => Text -> Text -> HtmlT m ()
scriptToggleShow checkName toggleId =
script_
[qq|
$('#{checkName}').on('change', (function()\{
var vis = this.checked ? "block" : "none";
document.getElementById("{toggleId}").style.display = vis;
\}));
|]
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) <-
unshare
$ 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) <-
unshare
$ 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 _) <- unshare sr
hrep <- unshare $ textarea 10 (Just "html") (toText h)
crep <- unshare $ textarea 10 (Just "css") mempty
jrep <- unshare $ textarea 10 (Just "js") mempty
u <- unshare $ 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'
repChoice :: (Monad m) => Int -> [(Text, SharedRep m a)] -> SharedRep m a
repChoice initt xs =
bimap hmap mmap dd
<<*>> foldr (\x a -> bimap (:) (:) x <<*>> a) (pure []) cs
where
ts = fst <$> xs
cs = snd <$> xs
dd = dropdownSum takeText id Nothing ts t0
t0 = ts List.!! initt
hmap dd' cs' =
div_
( dd'
<> mconcat (zipWith (\c t -> subtype c t0 t) cs' ts)
)
mmap dd' cs' = maybe (List.head cs') (cs' List.!!) (List.elemIndex dd' ts)
selectItems :: [Text] -> HashMap.HashMap Text a -> [(Text,a)]
selectItems ks m =
HashMap.toList $
HashMap.filterWithKey (\k _ -> k `elem` ks) m
repItemsSelect :: Monad m => [Text] -> [Text] -> SharedRep m [Text]
repItemsSelect init full =
dropdownMultiple (A.takeWhile (`notElem` ([',']::[Char]))) id (Just "items") full init
subtype :: With a => a -> Text -> Text -> a
subtype h origt t =
with
h
[ class__ "subtype ",
data_ "sumtype" t,
style_ ("display:" <> bool "block" "none" (origt /= t))
]