String.hs

-- | A renderer that produces a native Haskell 'String', mostly meant for
-- debugging purposes.
--
{-# LANGUAGE OverloadedStrings #-}
module Haste.Markup.Renderer.String
    ( fromChoiceString
    , renderMarkup
    , renderHtml
    ) where

import Data.List (isInfixOf)

import Haste.Prim (JSString, fromJSStr, toJSStr)

import Haste.Markup.Internal

-- | Escape predefined XML entities in a string
--
escapeMarkupEntities :: String  -- ^ String to escape
                   -> String  -- ^ String to append
                   -> String  -- ^ Resulting string
escapeMarkupEntities []     k = k
escapeMarkupEntities (c:cs) k = case c of
    '<'  -> '&' : 'l' : 't' : ';'             : escapeMarkupEntities cs k
    '>'  -> '&' : 'g' : 't' : ';'             : escapeMarkupEntities cs k
    '&'  -> '&' : 'a' : 'm' : 'p' : ';'       : escapeMarkupEntities cs k
    '"'  -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeMarkupEntities cs k
    '\'' -> '&' : '#' : '3' : '9' : ';'       : escapeMarkupEntities cs k
    x    -> x                                 : escapeMarkupEntities cs k

-- AJ: TODO: Convert to use native JS foldr
tFoldr :: (Char -> String -> String) -> String -> JSString -> String
tFoldr op k s = foldr op k $ fromJSStr s

tIsInfixOf :: JSString -> JSString -> Bool
tIsInfixOf k s = fromJSStr k `isInfixOf` fromJSStr s

-- | Render a 'ChoiceString'.
--
fromChoiceString :: ChoiceString  -- ^ String to render
                 -> String        -- ^ String to append
                 -> String        -- ^ Resulting string
fromChoiceString (Static s)     = getString s
fromChoiceString (String s)     = escapeMarkupEntities s
fromChoiceString (Text s)       = escapeMarkupEntities $ fromJSStr s
fromChoiceString (PreEscaped x) = case x of
    String s -> (s ++)
    Text   s -> \k -> tFoldr (:) k s
    s        -> fromChoiceString s
fromChoiceString (External x) = case x of
    -- Check that the sequence "</" is *not* in the external data.
    String s     -> if "</" `isInfixOf` s then id else (s ++)
    Text   s     -> if "</" `tIsInfixOf` s then id else (\k -> tFoldr (:) k s)
    s            -> fromChoiceString s
fromChoiceString (AppendChoiceString x y) =
    fromChoiceString x . fromChoiceString y
fromChoiceString EmptyChoiceString = id
{-# INLINE fromChoiceString #-}

-- | Render some 'Markup' to an appending 'String'.
--
renderString :: Markup    -- ^ Markup to render
             -> String  -- ^ String to append
             -> String  -- ^ Resulting String
renderString = go id
  where
    go :: (String -> String) -> MarkupM b -> String -> String
    go attrs (Parent _ open close content) =
        getString open . attrs . ('>' :) . go id content . getString close
    go attrs (CustomParent tag content) =
        ('<' :) . fromChoiceString tag . attrs . ('>' :) .  go id content .
        ("</" ++) . fromChoiceString tag . ('>' :)
    go attrs (Leaf _ begin end) = getString begin . attrs . getString end
    go attrs (CustomLeaf tag close) =
        ('<' :) . fromChoiceString tag . attrs .
        (if close then (" />" ++) else ('>' :))
    go attrs (AddAttribute _ key value h) = flip go h $
        getString key . fromChoiceString value . ('"' :) . attrs
    go attrs (AddCustomAttribute key value h) = flip go h $
        (' ' :) . fromChoiceString key . ("=\"" ++) . fromChoiceString value .
        ('"' :) .  attrs
    go _ (Content content) = fromChoiceString content
    go attrs (Append h1 h2) = go attrs h1 . go attrs h2
    go _ Empty = id
    {-# NOINLINE go #-}
{-# INLINE renderString #-}

-- | Render markup to a lazy 'String'.
--
renderMarkup :: Markup -> String
renderMarkup html = renderString html ""
{-# INLINE renderMarkup #-}

renderHtml :: Markup -> String
renderHtml = renderMarkup
{-# INLINE renderHtml #-}
{-# DEPRECATED renderHtml
    "Use renderHtml from Text.Blaze.Html.Renderer.String instead" #-}