{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Key generators and miscellaneous html utilities.
--
-- Uses the lucid 'Lucid.Html'.
module Web.Page.Html
( class__,
toText,
genName,
genNamePre,
libCss,
libJs,
fromHex,
toHex,
HtmlT,
Html,
)
where
import Codec.Picture.Types (PixelRGB8 (..))
import Control.Monad.State
import Data.Attoparsec.Text
import Data.Bool
import Data.Text
import Data.Text.Format
import qualified Data.Text.Lazy as Lazy
import Data.Text.Lazy.Builder (toLazyText)
import Lucid
import Numeric
import Prelude
-- | FIXME: A horrible hack to separate class id's
class__ :: Text -> Attribute
class__ t = class_ (" " <> t <> " ")
-- | Convert html to text
toText :: Html a -> Text
toText = Lazy.toStrict . renderText
-- | name supply for html elements
genName :: (MonadState Int m) => m Text
genName = do
modify (+ 1)
(pack . show) <$> get
-- | sometimes a number doesn't work properly in html (or js???), and an alpha prefix seems to help
genNamePre :: (MonadState Int m) => Text -> m Text
genNamePre pre = (pre <>) <$> genName
-- | Convert a link to a css library from text to html.
--
-- >>> libCss "https://stackpath.bootstrapcdn.com/bootstrap/4.3.1/css/bootstrap.min.css"
--
libCss :: Text -> Html ()
libCss url =
link_
[ rel_ "stylesheet",
href_ url
]
-- | Convert a link to a js library from text to html.
--
-- >>> libJs "https://code.jquery.com/jquery-3.3.1.slim.min.js"
--
libJs :: Text -> Html ()
libJs url = with (script_ mempty) [src_ url]
-- | convert from #xxxxxx to 'PixelRGB8'
fromHex :: Parser PixelRGB8
fromHex =
( \((r, g), b) ->
PixelRGB8 (fromIntegral r) (fromIntegral g) (fromIntegral b)
)
. (\(f, b) -> (f `divMod` (256 :: Int), b))
. (`divMod` 256)
<$> (string "#" *> hexadecimal)
-- | convert from 'PixelRGB8' to #xxxxxx
toHex :: PixelRGB8 -> Text
toHex (PixelRGB8 r g b) =
"#"
<> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex r)
<> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex g)
<> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ hex b)
-- | FIXME: `ToHtml a` is used throughout, mostly because `Show a` gives "\"text\"" for show "text", and hilarity ensues when rendering this to a web page, and I couldn't work out how to properly get around this.
--
-- Hence, these orphans.
instance ToHtml Double where
toHtml = toHtml . (pack . show)
toHtmlRaw = toHtmlRaw . (pack . show)
instance ToHtml Bool where
toHtml = toHtml . bool ("false" :: Text) "true"
toHtmlRaw = toHtmlRaw . bool ("false" :: Text) "true"
instance ToHtml Int where
toHtml = toHtml . (pack . show)
toHtmlRaw = toHtmlRaw . (pack . show)
instance ToHtml PixelRGB8 where
toHtml = toHtml . toHex
toHtmlRaw = toHtmlRaw . toHex
instance ToHtml () where
toHtml = const "()"
toHtmlRaw = const "()"