{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wall #-}
module Web.Page.Examples
( page1
, page2
, cfg2
, RepExamples(..)
, repExamples
, Shape(..)
, fromShape
, toShape
, SumTypeExample(..)
, repSumTypeExample
, SumType2Example(..)
, repSumType2Example
, listifyExample
, listifyMaybeExample
, fiddleExample
) where
import Control.Category (id)
import Control.Lens hiding ((.=))
import Data.Attoparsec.Text
import Data.Biapplicative
import Lucid
import Protolude hiding ((<<*>>))
import Web.Page
import qualified Clay
page1 :: Page
page1 =
#htmlBody .~ button1 $
#cssBody .~ PageCss css1 $
#jsGlobal .~ mempty $
#jsOnLoad .~ click $
#libsCss .~ (libCss <$> cssLibs) $
#libsJs .~ (libJs <$> jsLibs) $
mempty
page2 :: Page
page2 =
#libsCss .~ (libCss <$> cssLibsLocal) $
#libsJs .~ (libJs <$> jsLibsLocal) $
page1
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 :: PageJs
click = PageJsText [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
, repShape :: Shape
, repColor :: PixelRGB8
} 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 show (Just "dropdown") (show <$> [1..5::Int]) 3
drt <- toShape <$> dropdown takeText id (Just "shape") (["Circle", "Square"]) (fromShape SquareShape)
col <- colorPicker (Just "color") (PixelRGB8 56 128 200)
pure (RepExamples t ta n ds' c tog dr drt col)
listifyExample :: (Monad m) => Int -> SharedRep m [Int]
listifyExample n =
accordionListify (Just "accordianListify") "al" Nothing
(\l a -> sliderI (Just l) (0::Int) n 1 a) ((\x -> "[" <> show x <> "]") <$> [0..n] :: [Text]) [0..n]
listifyMaybeExample :: (Monad m) => Int -> SharedRep m [Int]
listifyMaybeExample n =
listifyMaybe' (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