{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
module Web.Rep.Examples
( page1,
page2,
pagemj,
cfg2,
RepExamples (..),
repExamples,
Shape (..),
fromShape,
toShape,
SumTypeExample (..),
repSumTypeExample,
SumType2Example (..),
repSumType2Example,
listExample,
listRepExample,
fiddleExample,
)
where
import qualified Clay
import Control.Lens hiding ((.=))
import Data.Attoparsec.Text
import Lucid
import NumHask.Prelude
import Text.InterpolatedString.Perl6
import Web.Rep
page1 :: Page
page1 =
#htmlBody .~ button1
$ #cssBody .~ RepCss css1
$ #jsGlobal .~ mempty
$ #jsOnLoad .~ click
$ #libsCss .~ (libCss <$> cssLibs)
$ #libsJs .~ (libJs <$> jsLibs)
$ mempty
page2 :: Page
page2 =
#libsCss .~ (libCss <$> cssLibsLocal)
$ #libsJs .~ (libJs <$> jsLibsLocal)
$ page1
pagemj :: Page
pagemj = mathjaxPage & #htmlBody .~ htmlMathjaxExample
htmlMathjaxExample :: HtmlT Identity ()
htmlMathjaxExample =
p_ "double dollar:"
<> p_ "$$\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$$"
<> p_ "single dollar for inline: $\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}$"
<> p_ "escaped brackets for inline mathjax: \\(\\sum_{i=0}^n i^2 = \\frac{(n^2+n)(2n+1)}{6}\\)"
cfg2 :: PageConfig
cfg2 =
#concerns .~ Separated
$ #pageRender .~ Pretty
$ #structure .~ Headless
$ #localdirs .~ ["test/static"]
$ #filenames .~ (("other/cfg2" <>) <$> suffixes)
$ defaultPageConfig ""
cssLibs :: [Text]
cssLibs =
["http://maxcdn.bootstrapcdn.com/font-awesome/4.3.0/css/font-awesome.min.css"]
cssLibsLocal :: [Text]
cssLibsLocal = ["css/font-awesome.min.css"]
jsLibs :: [Text]
jsLibs = ["http://code.jquery.com/jquery-1.6.3.min.js"]
jsLibsLocal :: [Text]
jsLibsLocal = ["jquery-2.1.3.min.js"]
css1 :: Css
css1 = do
Clay.fontSize (Clay.px 10)
Clay.fontFamily ["Arial", "Helvetica"] [Clay.sansSerif]
"#btnGo" Clay.? do
Clay.marginTop (Clay.px 20)
Clay.marginBottom (Clay.px 20)
"#btnGo.on" Clay.? Clay.color Clay.green
click :: RepJs
click =
RepJsText
[q|
$('#btnGo').click( function() {
$('#btnGo').toggleClass('on');
alert('bada bing!');
});
|]
button1 :: Html ()
button1 =
with
button_
[id_ "btnGo", Lucid.type_ "button"]
("Go " <> with i_ [class__ "fa fa-play"] mempty)
data RepExamples
= RepExamples
{ repTextbox :: Text,
repTextarea :: Text,
repSliderI :: Int,
repSlider :: Double,
repCheckbox :: Bool,
repToggle :: Bool,
repDropdown :: Int,
repDropdownMultiple :: [Int],
repShape :: Shape,
repColor :: Text
}
deriving (Show, Eq, Generic)
data Shape = SquareShape | CircleShape deriving (Eq, Show, Generic)
toShape :: Text -> Shape
toShape t = case t of
"Circle" -> CircleShape
"Square" -> SquareShape
_ -> CircleShape
fromShape :: Shape -> Text
fromShape CircleShape = "Circle"
fromShape SquareShape = "Square"
repExamples :: (Monad m) => SharedRep m RepExamples
repExamples = do
t <- textbox (Just "textbox") "sometext"
ta <- textarea 3 (Just "textarea") "no initial value & multi-line text\\nrenders is not ok?/"
n <- sliderI (Just "int slider") 0 5 1 3
ds' <- slider (Just "double slider") 0 1 0.1 0.5
c <- checkbox (Just "checkbox") True
tog <- toggle (Just "toggle") False
dr <- dropdown decimal (pack . show) (Just "dropdown") (pack . show <$> [1 .. 5 :: Int]) 3
drm <- dropdownMultiple decimal (pack . show) (Just "dropdown multiple") (pack . show <$> [1 .. 5 :: Int]) [2, 4]
drt <- toShape <$> dropdown takeText id (Just "shape") ["Circle", "Square"] (fromShape SquareShape)
col <- colorPicker (Just "color") "#454e56"
pure (RepExamples t ta n ds' c tog dr drm drt col)
listExample :: (Monad m) => Int -> SharedRep m [Int]
listExample n =
accordionList
(Just "accordianListify")
"al"
Nothing
(\l a -> sliderI (Just l) (0 :: Int) n 1 a)
((\x -> "[" <> (pack . show) x <> "]") <$> [0 .. n] :: [Text])
[0 .. n]
listRepExample :: (Monad m) => Int -> SharedRep m [Int]
listRepExample n =
listRep
(Just "listifyMaybe")
"alm"
(checkbox Nothing)
(sliderI Nothing (0 :: Int) n 1)
n
3
[0 .. 4]
fiddleExample :: Concerns Text
fiddleExample =
Concerns
mempty
mempty
[q|
<div class=" form-group-sm "><label for="1">fiddle example</label><input max="10.0" value="3.0" oninput="jsb.event({ 'element': this.id, 'value': this.value});" step="1.0" min="0.0" id="1" type="range" class=" custom-range form-control-range "></div>
|]
data SumTypeExample = SumInt Int | SumOnly | SumText Text deriving (Eq, Show, Generic)
sumTypeText :: SumTypeExample -> Text
sumTypeText (SumInt _) = "SumInt"
sumTypeText SumOnly = "SumOnly"
sumTypeText (SumText _) = "SumText"
repSumTypeExample :: (Monad m) => Int -> Text -> SumTypeExample -> SharedRep m SumTypeExample
repSumTypeExample defi deft defst =
bimap hmap mmap repst <<*>> repi <<*>> rept
where
repi = sliderI Nothing 0 20 1 defInt
rept = textbox Nothing defText
repst =
dropdownSum
takeText
id
(Just "SumTypeExample")
["SumInt", "SumOnly", "SumText"]
(sumTypeText defst)
hmap repst' repi' rept' =
div_
( repst'
<> with
repi'
[ class__ "subtype ",
data_ "sumtype" "SumInt",
style_
( "display:"
<> bool "block" "none" (sumTypeText defst /= "SumInt")
)
]
<> with
rept'
[ class__ "subtype ",
data_ "sumtype" "SumText",
style_
("display:" <> bool "block" "none" (sumTypeText defst /= "SumText"))
]
)
mmap repst' repi' rept' =
case repst' of
"SumInt" -> SumInt repi'
"SumOnly" -> SumOnly
"SumText" -> SumText rept'
_ -> SumOnly
defInt = case defst of
SumInt i -> i
_ -> defi
defText = case defst of
SumText t -> t
_ -> deft
data SumType2Example = SumOutside Int | SumInside SumTypeExample deriving (Eq, Show, Generic)
sumType2Text :: SumType2Example -> Text
sumType2Text (SumOutside _) = "SumOutside"
sumType2Text (SumInside _) = "SumInside"
repSumType2Example :: (Monad m) => Int -> Text -> SumTypeExample -> SumType2Example -> SharedRep m SumType2Example
repSumType2Example defi deft defst defst2 =
bimap hmap mmap repst2 <<*>> repst <<*>> repoi
where
repoi = sliderI Nothing 0 20 1 defInt
repst = repSumTypeExample defi deft SumOnly
repst2 =
dropdownSum
takeText
id
(Just "SumType2Example")
["SumOutside", "SumInside"]
(sumType2Text defst2)
hmap repst2' repst' repoi' =
div_
( repst2'
<> with
repst'
[ class__ "subtype ",
data_ "sumtype" "SumInside",
style_
( "display:"
<> bool "block" "none" (sumType2Text defst2 /= "SumInside")
)
]
<> with
repoi'
[ class__ "subtype ",
data_ "sumtype" "SumOutside",
style_
( "display:"
<> bool "block" "none" (sumType2Text defst2 /= "SumOutside")
)
]
)
mmap repst2' repst' repoi' =
case repst2' of
"SumOutside" -> SumOutside repoi'
"SumInside" -> SumInside repst'
_ -> SumOutside repoi'
defInt = case defst of
SumInt i -> i
_ -> defi