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

import Blaze.ByteString.Builder (Builder)
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function ((.), ($))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
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 Prelude (Num(..), undefined)
import System.IO (IO)
import Text.Blaze as B
import Text.Blaze.Internal as B hiding (null)
import Text.Show (Show(..))
import qualified Blaze.ByteString.Builder as BS
import qualified Blaze.ByteString.Builder.Html.Utf8 as BS
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as BS
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Renderer.Utf8 as BS

-- | 'Attribute' in 'Maybe'.
infixl 1 !??
(!??) :: Attributable h => h -> Maybe Attribute -> h
(!??) h = maybe h (h !)

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

whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust Nothing _f = pure ()
whenJust (Just a) f = f a

whenSome :: (Applicative m, Foldable f) => f a -> (f a -> m ()) -> m ()
whenSome x _f | null x = pure ()
whenSome x f = f x

whenText :: Applicative m => Text -> (Text -> m ()) -> m ()
whenText "" _f = pure ()
whenText t f = f t

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

-- * Class 'AttrValue'
class AttrValue a where
	attrValue :: a -> H.AttributeValue
instance AttrValue Char where
	attrValue = fromString . pure
instance AttrValue Text where
	attrValue = fromString . Text.unpack
instance AttrValue TL.Text where
	attrValue = fromString . TL.unpack
instance AttrValue Int where
	attrValue = fromString . show
instance AttrValue [Char] where
	attrValue = fromString

-- * Class 'MayAttr'
class MayAttr a where
	mayAttr :: (AttributeValue -> Attribute) -> a -> Maybe Attribute
instance MayAttr a => MayAttr (Maybe a) where
	mayAttr a t = t >>= mayAttr a
instance MayAttr Text where
	mayAttr _ "" = Nothing
	mayAttr a t  = Just (a $ fromString $ Text.unpack t)
instance MayAttr Int where
	mayAttr a t  = Just (a $ fromString $ show t)
instance MayAttr [Char] where
	mayAttr _ "" = Nothing
	mayAttr a t  = Just (a $ fromString t)

-- * Type 'StateMarkup'
-- | Composing state and markups.
type StateMarkup st = Compose (S.State st) B.MarkupM
instance Monad (StateMarkup st) where
	return = pure
	Compose sma >>= a2csmb =
		Compose $ sma >>= \ma ->
			case ma >>= B.Empty . a2csmb of
			 B.Append _ma (B.Empty csmb) ->
				B.Append ma <$> getCompose csmb
			 _ -> undefined
instance IsString (StateMarkup st ()) where
	fromString = Compose . return . fromString

-- | Lift a 'B.MarkupM' constructor to a 'StateMarkup' one.
($$) :: (B.MarkupM a -> B.MarkupM a) -> StateMarkup st a -> StateMarkup st a
($$) f m = Compose $ f <$> getCompose m
infixr 0 $$

liftStateMarkup :: S.State st a -> StateMarkup st a
liftStateMarkup = Compose . (return <$>)

runStateMarkup :: st -> StateMarkup st a -> (B.MarkupM a, st)
runStateMarkup st = (`S.runState` st) . getCompose

local :: Monad m => (s -> s) -> S.StateT s m b -> S.StateT s m b
local f a = do
	s <- S.get
	S.put (f s)
	r <- a
	S.put s
	return r

-- * 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 = "  "
	bs_Attrs i ind t_tag attrs =
		case {-List.reverse-} attrs of
		 [] -> mempty
		 [a] -> a
		 a0:as ->
			let ind_key = BS.fromText $ Text.replicate (Text.length t_tag + 1) " " in
			let ind_attr =
				case i of
				 IndentTagChildren -> ind<>ind_key
				 IndentTagPreserve -> mempty
				 IndentTagText -> mempty in
			a0 <> foldMap (ind_attr <>) as
	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)
		 <> bs_Attrs i ind (getText 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.copyByteString (getUtf8ByteString close)
	go i ind attrs (CustomParent tag content) =
		let i' = indentTag (t_ChoiceString tag) in
		let t_tag = t_ChoiceString tag in
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.fromChar '<'
		 <> BS.fromText t_tag
		 <> bs_Attrs i ind t_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)
		 <> bs_Attrs i ind (getText tag) attrs
		 <> BS.copyByteString (getUtf8ByteString end)
	go i ind attrs (CustomLeaf tag close _) =
		let t_tag = t_ChoiceString tag in
		(if i==IndentTagChildren then ind else mempty)
		 <> BS.fromChar '<'
		 <> BS.fromText t_tag
		 <> bs_Attrs i ind t_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 _i _ind _attrs (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 #-}