{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Blaze.Utils where

import Blaze.ByteString.Builder (Builder)
import Control.Monad (return)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function ((.), ($))
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
import System.IO (IO)
import Text.Blaze as B
import Text.Blaze.Internal as B
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Blaze.ByteString.Builder as BS
import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as Text
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Renderer.Utf8 as BS
import qualified Data.Text.Encoding as BS

-- | 'Attribute' in 'Maybe'.
infixl 1 !??
(!??) :: Attributable h => h -> (Maybe a, a -> Attribute) -> h
(!??) h (m,a) = maybe h (\x -> h ! a x) m

whenMarkup :: MarkupM a -> MarkupM () -> MarkupM ()
whenMarkup Empty{} _b = return ()
whenMarkup _a b = b

instance Semigroup H.AttributeValue where
	(<>) = mappend

-- * Class 'Attributable'
class AttrValue a where
	attrValue :: a -> H.AttributeValue
instance AttrValue Text where
	attrValue = fromString . Text.unpack
instance AttrValue Int where
	attrValue = fromString . show

-- * Type 'IndentTag'
data IndentTag
 =   IndentTagChildren
 |   IndentTagText
 |   IndentTagPreserve
 deriving (Eq,Show)

-- | Render some 'Markup' to a 'Builder'.
-- 
-- An 'IndentTag' is queried on each tag
-- to indent tags differently according to their names.
prettyMarkupBuilder :: (Text -> IndentTag) -> Markup -> Builder
prettyMarkupBuilder indentTag = go IndentTagPreserve "\n" mempty
	where
	inc :: Builder
	inc = "  "
	go :: IndentTag -> Builder -> Builder -> MarkupM b -> Builder
	go i ind attrs (Parent tag open close content) =
		let i' = indentTag (getText tag) in
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.copyByteString (getUtf8ByteString open)
		 <> attrs
		 <> BS.fromChar '>'
		 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
		 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
		 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
		 <> BS.copyByteString (getUtf8ByteString close)
	go i ind attrs (CustomParent tag content) =
		let i' = indentTag (t_ChoiceString tag) in
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.fromChar '<'
		 <> bs_ChoiceString tag
		 <> attrs
		 <> BS.fromChar '>'
		 <> (if i==IndentTagChildren && i'==IndentTagText then ind<>inc else mempty)
		 <> go i' (if i'/=IndentTagPreserve then ind<>inc else ind) mempty content
		 <> (if (i==IndentTagChildren && i'==IndentTagText) || i'==IndentTagChildren then ind else mempty)
		 <> BS.fromByteString "</"
		 <> bs_ChoiceString tag
		 <> BS.fromChar '>'
	go i ind attrs (Leaf _tag begin end _) =
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.copyByteString (getUtf8ByteString begin)
		 <> attrs
		 <> BS.copyByteString (getUtf8ByteString end)
	go i ind attrs (CustomLeaf tag close _) =
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.fromChar '<'
		 <> bs_ChoiceString tag
		 <> attrs
		 <> (if close then BS.fromByteString " />" else BS.fromChar '>')
	go i ind attrs (AddAttribute _ key value m) =
		go i ind (BS.copyByteString (getUtf8ByteString key)
		 <> bs_ChoiceString value
		 <> BS.fromChar '"'
		 <> attrs) m
	go i ind attrs (AddCustomAttribute key value m) =
		go i ind (BS.fromChar ' '
		 <> bs_ChoiceString key
		 <> BS.fromByteString "=\""
		 <> bs_ChoiceString value
		 <> BS.fromChar '"'
		 <> attrs) m
	go i ind _attrs (Content content _) =
		if i/=IndentTagPreserve
		then indentChoiceString ind content
		else bs_ChoiceString content
	go i ind _attrs (Comment comment _) =
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.fromByteString "<!--"
		 <> (if i==IndentTagChildren
			then indentChoiceString ind
			else bs_ChoiceString
		 ) comment
		 <> BS.fromByteString "-->"
	go i ind attrs (Append m1 m2) =
		go i ind attrs m1 <>
		go i ind attrs m2
	go _ip _ind _ (Empty _) = mempty
	{-# NOINLINE go #-}

-- | Render 'Markup' to a lazy UTF-8 encoded 'BSL.ByteString'.
prettyMarkup :: (Text -> IndentTag) -> Markup -> BSL.ByteString
prettyMarkup ind = BS.toLazyByteString . prettyMarkupBuilder ind

prettyMarkupIO :: (Text -> IndentTag) -> (BS.ByteString -> IO ()) -> Markup -> IO ()
prettyMarkupIO ind io = BS.toByteStringIO io . prettyMarkupBuilder ind

bs_ChoiceString :: ChoiceString -> Builder
bs_ChoiceString cs = BS.renderMarkupBuilder (Content cs ())

t_ChoiceString :: ChoiceString -> Text
t_ChoiceString = BS.decodeUtf8 . BS.toByteString . bs_ChoiceString

-- | @indentText ind txt@ indent 'tct' with 'ind' at newlines.
indentText :: Builder -> Text -> Builder
indentText ind =
	mconcat .
	List.intersperse ind .
	(BS.fromHtmlEscapedText <$>) .
	Text.splitOn "\n"

-- | Render an indented 'ChoiceString'.
indentChoiceString :: Builder -> ChoiceString -> Builder
indentChoiceString ind (Static s)     = indentText ind $ getText s
indentChoiceString ind (String s)     = indentText ind $ Text.pack s
indentChoiceString ind (Text s)       = indentText ind s
indentChoiceString ind (ByteString s) = indentText ind $ BS.decodeUtf8 s
indentChoiceString ind (PreEscaped x) = case x of
	 String s -> indentText ind $ Text.pack s
	 Text   s -> indentText ind s
	 s        -> indentChoiceString ind s
indentChoiceString ind (External x) = case x of
	 -- Check that the sequence "</" is *not* in the external data.
	 String s     -> if "</" `List.isInfixOf` s then mempty else BS.fromString s
	 Text   s     -> if "</" `Text.isInfixOf` s then mempty else BS.fromText s
	 ByteString s -> if "</" `BS.isInfixOf`   s then mempty else BS.fromByteString s
	 s            -> indentChoiceString ind s
indentChoiceString ind (AppendChoiceString x y) =
	indentChoiceString ind x <>
	indentChoiceString ind y
indentChoiceString ind EmptyChoiceString = indentText ind mempty
{-# INLINE indentChoiceString #-}