{-# language OverloadedStrings #-}

module Text.XHtml.Extras where

import qualified Data.Text.Lazy as LText

import Text.XHtml.Internals
import Text.XHtml.Strict.Elements
import Text.XHtml.Strict.Attributes

--
-- * Converting strings to HTML
--

-- | Convert a 'String' to 'Html', converting
--   characters that need to be escaped to HTML entities.
stringToHtml :: String -> Html
stringToHtml :: [Char] -> Html
stringToHtml = [Char] -> Html
primHtml ([Char] -> Html) -> ([Char] -> [Char]) -> [Char] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Char]
builderToString (Builder -> [Char]) -> ([Char] -> Builder) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Builder
stringToHtmlString

{-# INLINE stringToHtml #-}

-- | This converts a string, but keeps spaces as non-line-breakable.
lineToHtml :: String -> Html
lineToHtml :: [Char] -> Html
lineToHtml =
    Builder -> Html
primHtmlNonEmptyBuilder (Builder -> Html) -> ([Char] -> Builder) -> [Char] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Builder
stringToHtmlString ([Char] -> Builder) -> ([Char] -> [Char]) -> [Char] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Char]) -> [Char] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> [Char]
htmlizeChar2
  where
    htmlizeChar2 :: Char -> [Char]
htmlizeChar2 Char
' ' = [Char]
" "
    htmlizeChar2 Char
c   = [Char
c]

{-# INLINE lineToHtml #-}

-- | This converts a string, but keeps spaces as non-line-breakable,
--   and adds line breaks between each of the strings in the input list.
linesToHtml :: [String] -> Html
linesToHtml :: [[Char]] -> Html
linesToHtml []     = Html
noHtml
linesToHtml [[Char]
x]    = [Char] -> Html
lineToHtml [Char]
x
linesToHtml ([Char]
x:[[Char]]
xs) = [Char] -> Html
lineToHtml [Char]
x Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ [[Char]] -> Html
linesToHtml [[Char]]
xs

{-# INLINE linesToHtml #-}

--
-- * Html abbreviations
--

primHtmlChar  :: String -> Html

-- | Copyright sign.
copyright     :: Html

-- | Non-breaking space.
spaceHtml     :: Html
bullet        :: Html


primHtmlChar :: [Char] -> Html
primHtmlChar [Char]
x = [Char] -> Html
primHtml ([Char]
"&" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";")
copyright :: Html
copyright      = [Char] -> Html
primHtmlChar [Char]
"copy"
spaceHtml :: Html
spaceHtml      = [Char] -> Html
primHtmlChar [Char]
"nbsp"
bullet :: Html
bullet         = [Char] -> Html
primHtmlChar [Char]
"#149"

-- | Same as 'paragraph'.
p :: Html -> Html
p :: Html -> Html
p =  Html -> Html
paragraph

--
-- * Hotlinks
--

type URL = LText.Text

data HotLink = HotLink {
      HotLink -> Text
hotLinkURL        :: URL,
      HotLink -> Html
hotLinkContents   :: Html,
      HotLink -> [HtmlAttr]
hotLinkAttributes :: [HtmlAttr]
      } deriving Int -> HotLink -> [Char] -> [Char]
[HotLink] -> [Char] -> [Char]
HotLink -> [Char]
(Int -> HotLink -> [Char] -> [Char])
-> (HotLink -> [Char])
-> ([HotLink] -> [Char] -> [Char])
-> Show HotLink
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> HotLink -> [Char] -> [Char]
showsPrec :: Int -> HotLink -> [Char] -> [Char]
$cshow :: HotLink -> [Char]
show :: HotLink -> [Char]
$cshowList :: [HotLink] -> [Char] -> [Char]
showList :: [HotLink] -> [Char] -> [Char]
Show

instance HTML HotLink where
      toHtml :: HotLink -> Html
toHtml HotLink
hl = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! (Text -> HtmlAttr
href (HotLink -> Text
hotLinkURL HotLink
hl) HtmlAttr -> [HtmlAttr] -> [HtmlAttr]
forall a. a -> [a] -> [a]
: HotLink -> [HtmlAttr]
hotLinkAttributes HotLink
hl)
                      (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< HotLink -> Html
hotLinkContents HotLink
hl

instance ADDATTRS HotLink where
      HotLink
hl ! :: HotLink -> [HtmlAttr] -> HotLink
! [HtmlAttr]
attr = HotLink
hl { hotLinkAttributes = hotLinkAttributes hl ++ attr }

hotlink :: URL -> Html -> HotLink
hotlink :: Text -> Html -> HotLink
hotlink Text
url Html
h = HotLink {
      hotLinkURL :: Text
hotLinkURL = Text
url,
      hotLinkContents :: Html
hotLinkContents = Html
h,
      hotLinkAttributes :: [HtmlAttr]
hotLinkAttributes = [] }


--
-- * Lists
--

-- (Abridged from Erik Meijer's Original Html library)

ordList   :: (HTML a) => [a] -> Html
ordList :: forall a. HTML a => [a] -> Html
ordList [a]
items = Html -> Html
olist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (a -> Html) -> [a] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> Html
li (Html -> Html) -> a -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<) [a]
items

unordList :: (HTML a) => [a] -> Html
unordList :: forall a. HTML a => [a] -> Html
unordList [a]
items = Html -> Html
ulist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (a -> Html) -> [a] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> Html
li (Html -> Html) -> a -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<) [a]
items

defList   :: (HTML a,HTML b) => [(a,b)] -> Html
defList :: forall a b. (HTML a, HTML b) => [(a, b)] -> Html
defList [(a, b)]
items
 = Html -> Html
dlist (Html -> Html) -> [[Html]] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ [ Html -> Html
dterm (Html -> Html) -> a -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< a
dt, Html -> Html
ddef (Html -> Html) -> b -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< b
dd ] | (a
dt,b
dd) <- [(a, b)]
items ]

--
-- * Forms
--

widget :: LText.Text -> LText.Text -> [HtmlAttr] -> Html
widget :: Text -> Text -> [HtmlAttr] -> Html
widget Text
w Text
n [HtmlAttr]
attrs = Html
input Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([Text -> HtmlAttr
thetype Text
w] [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++ [HtmlAttr]
ns [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++ [HtmlAttr]
attrs)
  where ns :: [HtmlAttr]
ns = if Text -> Bool
LText.null Text
n then [] else [Text -> HtmlAttr
name Text
n,Text -> HtmlAttr
identifier Text
n]

checkbox :: LText.Text -> LText.Text -> Html
hidden   :: LText.Text -> LText.Text -> Html
radio    :: LText.Text -> LText.Text -> Html
reset    :: LText.Text -> LText.Text -> Html
submit   :: LText.Text -> LText.Text -> Html
password :: LText.Text           -> Html
textfield :: LText.Text          -> Html
afile    :: LText.Text           -> Html
clickmap :: LText.Text           -> Html

checkbox :: Text -> Text -> Html
checkbox Text
n Text
v = Text -> Text -> [HtmlAttr] -> Html
widget Text
"checkbox" Text
n [Text -> HtmlAttr
value Text
v]
hidden :: Text -> Text -> Html
hidden   Text
n Text
v = Text -> Text -> [HtmlAttr] -> Html
widget Text
"hidden"   Text
n [Text -> HtmlAttr
value Text
v]
radio :: Text -> Text -> Html
radio    Text
n Text
v = Text -> Text -> [HtmlAttr] -> Html
widget Text
"radio"    Text
n [Text -> HtmlAttr
value Text
v]
reset :: Text -> Text -> Html
reset    Text
n Text
v = Text -> Text -> [HtmlAttr] -> Html
widget Text
"reset"    Text
n [Text -> HtmlAttr
value Text
v]
submit :: Text -> Text -> Html
submit   Text
n Text
v = Text -> Text -> [HtmlAttr] -> Html
widget Text
"submit"   Text
n [Text -> HtmlAttr
value Text
v]
password :: Text -> Html
password Text
n   = Text -> Text -> [HtmlAttr] -> Html
widget Text
"password" Text
n []
textfield :: Text -> Html
textfield Text
n  = Text -> Text -> [HtmlAttr] -> Html
widget Text
"text"     Text
n []
afile :: Text -> Html
afile    Text
n   = Text -> Text -> [HtmlAttr] -> Html
widget Text
"file"     Text
n []
clickmap :: Text -> Html
clickmap Text
n   = Text -> Text -> [HtmlAttr] -> Html
widget Text
"image"    Text
n []

{-# DEPRECATED menu "menu generates strange XHTML, and is not flexible enough. Roll your own that suits your needs." #-}
menu :: LText.Text -> [Html] -> Html
menu :: Text -> [Html] -> Html
menu Text
n [Html]
choices
   = Html -> Html
select (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
name Text
n] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
option (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
choice | Html
choice <- [Html]
choices ]

gui :: LText.Text -> Html -> Html
gui :: Text -> Html -> Html
gui Text
act = Html -> Html
form (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
action Text
act,Text -> HtmlAttr
method Text
"post"]