{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.XHtml.internals
-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of
--                Science and Technology, 1999-2001,
--                (c) Bjorn Bringert, 2004-2006
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Chris Dornan <[email protected]>
-- Stability   :  Stable
-- Portability :  Portable
--
-- Internals of the XHTML combinator library.
-----------------------------------------------------------------------------
module Text.XHtml.Internals where

import Data.Char
import qualified Data.Semigroup as Sem

infixr 2 +++  -- combining Html
infixr 7 <<   -- nesting Html
infixl 8 !    -- adding optional arguments

--
-- * Data types
--

-- | A important property of Html is that all strings inside the
-- structure are already in Html friendly format.
data HtmlElement
      = HtmlString String
        -- ^ ..just..plain..normal..text... but using &copy; and &amb;, etc.
      | HtmlTag {
              markupTag      :: String,
              markupAttrs    :: [HtmlAttr],
              markupContent  :: Html
              }
        -- ^ tag with internal markup

-- | Attributes with name and value.
data HtmlAttr = HtmlAttr String String


htmlAttrPair :: HtmlAttr -> (String,String)
htmlAttrPair (HtmlAttr n v) = (n,v)


newtype Html = Html { getHtmlElements :: [HtmlElement] }


--
-- * Classes
--

instance Show Html where
      showsPrec _ html = showString (renderHtmlFragment html)
      showList htmls   = foldr (.) id (map shows htmls)

instance Show HtmlAttr where
      showsPrec _ (HtmlAttr str val) =
              showString str .
              showString "=" .
              shows val

-- | @since 3000.2.2
instance Sem.Semigroup Html where
    (<>) = (+++)

instance Sem.Monoid Html where
    mempty = noHtml
    mappend = (Sem.<>)

-- | HTML is the class of things that can be validly put
-- inside an HTML tag. So this can be one or more 'Html' elements,
-- or a 'String', for example.
class HTML a where
      toHtml     :: a -> Html
      toHtmlFromList :: [a] -> Html

      toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])

instance HTML Html where
      toHtml a    = a

instance HTML Char where
      toHtml       a = toHtml [a]
      toHtmlFromList []  = Html []
      toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]

instance (HTML a) => HTML [a] where
      toHtml xs = toHtmlFromList xs

instance HTML a => HTML (Maybe a) where
      toHtml = maybe noHtml toHtml

class ADDATTRS a where
      (!) :: a -> [HtmlAttr] -> a

-- | CHANGEATTRS is a more expressive alternative to ADDATTRS
class CHANGEATTRS a where
      changeAttrs :: a -> ([HtmlAttr]->[HtmlAttr]) -> a

instance (ADDATTRS b) => ADDATTRS (a -> b) where
      fn ! attr        = \ arg -> fn arg ! attr

instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where
      changeAttrs fn f = \ arg -> changeAttrs (fn arg) f

instance ADDATTRS Html where
      (Html htmls) ! attr = Html (map addAttrs htmls)
        where
              addAttrs (html@(HtmlTag { markupAttrs = attrs }) )
                            = html { markupAttrs = attrs ++ attr }
              addAttrs html = html

instance CHANGEATTRS Html where
      changeAttrs (Html htmls) f = Html (map addAttrs htmls)
        where
              addAttrs (html@(HtmlTag { markupAttrs = attrs }) )
                            = html { markupAttrs = f attrs }
              addAttrs html = html


--
-- * Html primitives and basic combinators
--

-- | Put something inside an HTML element.
(<<) :: (HTML a) =>
        (Html -> b) -- ^ Parent
     -> a -- ^ Child
     -> b
fn << arg = fn (toHtml arg)


concatHtml :: (HTML a) => [a] -> Html
concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))

-- | Create a piece of HTML which is the concatenation
--   of two things which can be made into HTML.
(+++) :: (HTML a,HTML b) => a -> b -> Html
a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))

-- | An empty piece of HTML.
noHtml :: Html
noHtml = Html []

-- | Checks whether the given piece of HTML is empty.
isNoHtml :: Html -> Bool
isNoHtml (Html xs) = null xs

-- | Constructs an element with a custom name.
tag :: String -- ^ Element name
    -> Html -- ^ Element contents
    -> Html
tag str       htmls = Html [
      HtmlTag {
              markupTag = str,
              markupAttrs = [],
              markupContent = htmls }]

-- | Constructs an element with a custom name, and
--   without any children.
itag :: String -> Html
itag str = tag str noHtml

emptyAttr :: String -> HtmlAttr
emptyAttr s = HtmlAttr s s

intAttr :: String -> Int -> HtmlAttr
intAttr s i = HtmlAttr s (show i)

strAttr :: String -> String -> HtmlAttr
strAttr s t = HtmlAttr s (stringToHtmlString t)

htmlAttr :: String -> Html -> HtmlAttr
htmlAttr s t = HtmlAttr s (show t)


{-
foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
      -> (String -> a)
      -> Html
      -> a
foldHtml f g (HtmlTag str attr fmls)
      = f str attr (map (foldHtml f g) fmls)
foldHtml f g (HtmlString  str)
      = g str

-}

-- | Processing Strings into Html friendly things.
stringToHtmlString :: String -> String
stringToHtmlString = concatMap fixChar
    where
      fixChar '<' = "&lt;"
      fixChar '>' = "&gt;"
      fixChar '&' = "&amp;"
      fixChar '"' = "&quot;"
      fixChar c | ord c < 0x80 = [c]
      fixChar c = "&#" ++ show (ord c) ++ ";"


-- | This is not processed for special chars.
-- use stringToHtml or lineToHtml instead, for user strings,
-- because they understand special chars, like @'<'@.
primHtml :: String -> Html
primHtml x | null x    = Html []
           | otherwise = Html [HtmlString x]



--
-- * Html Rendering
--

mkHtml :: HTML html => html -> Html
mkHtml = (tag "html" ! [strAttr "xmlns" "http://www.w3.org/1999/xhtml"] <<)

-- | Output the HTML without adding newlines or spaces within the markup.
--   This should be the most time and space efficient way to
--   render HTML, though the ouput is quite unreadable.
showHtmlInternal :: HTML html =>
                    String -- ^ DOCTYPE declaration
                 -> html -> String
showHtmlInternal docType theHtml =
    docType ++ showHtmlFragment (mkHtml theHtml)

-- | Outputs indented HTML. Because space matters in
--   HTML, the output is quite messy.
renderHtmlInternal :: HTML html =>
                      String  -- ^ DOCTYPE declaration
                   -> html -> String
renderHtmlInternal docType theHtml =
      docType ++ "\n" ++ renderHtmlFragment (mkHtml theHtml) ++ "\n"

-- | Outputs indented HTML, with indentation inside elements.
--   This can change the meaning of the HTML document, and
--   is mostly useful for debugging the HTML output.
--   The implementation is inefficient, and you are normally
--   better off using 'showHtml' or 'renderHtml'.
prettyHtmlInternal :: HTML html =>
                      String -- ^ DOCTYPE declaration
                   -> html -> String
prettyHtmlInternal docType theHtml =
    docType ++ "\n" ++ prettyHtmlFragment (mkHtml theHtml)

-- | Render a piece of HTML without adding a DOCTYPE declaration
--   or root element. Does not add any extra whitespace.
showHtmlFragment :: HTML html => html -> String
showHtmlFragment h =
    (foldr (.) id $ map showHtml' $ getHtmlElements $ toHtml h) ""

-- | Render a piece of indented HTML without adding a DOCTYPE declaration
--   or root element. Only adds whitespace where it does not change
--   the meaning of the document.
renderHtmlFragment :: HTML html => html -> String
renderHtmlFragment h =
    (foldr (.) id $ map (renderHtml' 0) $ getHtmlElements $ toHtml h) ""

-- | Render a piece of indented HTML without adding a DOCTYPE declaration
--   or a root element.
--   The indentation is done inside elements.
--   This can change the meaning of the HTML document, and
--   is mostly useful for debugging the HTML output.
--   The implementation is inefficient, and you are normally
--   better off using 'showHtmlFragment' or 'renderHtmlFragment'.
prettyHtmlFragment :: HTML html => html -> String
prettyHtmlFragment =
    unlines . concat . map prettyHtml' . getHtmlElements . toHtml

-- | Show a single HTML element, without adding whitespace.
showHtml' :: HtmlElement -> ShowS
showHtml' (HtmlString str) = (++) str
showHtml'(HtmlTag { markupTag = name,
                    markupContent = html,
                    markupAttrs = attrs })
    = if isNoHtml html && elem name validHtmlITags
      then renderTag True name attrs ""
      else (renderTag False name attrs ""
            . foldr (.) id (map showHtml' (getHtmlElements html))
            . renderEndTag name "")

renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' _ (HtmlString str) = (++) str
renderHtml' n (HtmlTag
              { markupTag = name,
                markupContent = html,
                markupAttrs = attrs })
      = if isNoHtml html && elem name validHtmlITags
        then renderTag True name attrs (nl n)
        else (renderTag False name attrs (nl n)
             . foldr (.) id (map (renderHtml' (n+2)) (getHtmlElements html))
             . renderEndTag name (nl n))
    where
      nl n' = "\n" ++ replicate (n' `div` 8) '\t'
              ++ replicate (n' `mod` 8) ' '


prettyHtml' :: HtmlElement -> [String]
prettyHtml' (HtmlString str) = [str]
prettyHtml' (HtmlTag
              { markupTag = name,
                markupContent = html,
                markupAttrs = attrs })
      = if isNoHtml html && elem name validHtmlITags
        then
         [rmNL (renderTag True name attrs "" "")]
        else
         [rmNL (renderTag False name attrs "" "")] ++
          shift (concat (map prettyHtml' (getHtmlElements html))) ++
         [rmNL (renderEndTag name "" "")]
  where
      shift = map (\x -> "   " ++ x)
      rmNL = filter (/= '\n')


-- | Show a start tag
renderTag :: Bool       -- ^ 'True' if the empty tag shorthand should be used
          -> String     -- ^ Tag name
          -> [HtmlAttr] -- ^ Attributes
          -> String     -- ^ Whitespace to add after attributes
          -> ShowS
renderTag empty name attrs nl r
      = "<" ++ name ++ shownAttrs ++ nl ++ close ++ r
  where
      close = if empty then " />" else ">"

      shownAttrs = concat [' ':showPair attr | attr <- attrs ]

      showPair :: HtmlAttr -> String
      showPair (HtmlAttr key val)
              = key ++ "=\"" ++ val  ++ "\""

-- | Show an end tag
renderEndTag :: String -- ^ Tag name
             -> String -- ^ Whitespace to add after tag name
             -> ShowS
renderEndTag name nl r = "</" ++ name ++ nl ++ ">" ++ r


-- | The names of all elements which can represented using the empty tag
--   short-hand.
validHtmlITags :: [String]
validHtmlITags = [
                  "area",
                  "base",
                  "basefont",
                  "br",
                  "col",
                  "frame",
                  "hr",
                  "img",
                  "input",
                  "isindex",
                  "link",
                  "meta",
                  "param"
                 ]