{-# language OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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.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 GHC.Exts (IsList(..))
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 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.Encoding as BS
import qualified Data.Text.Lazy as TL
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Renderer.Utf8 as BS
import qualified Text.Megaparsec as P

import Control.Monad.Utils

-- | '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
-}
instance IsList H.AttributeValue where
	type Item AttributeValue = AttributeValue
	fromList = mconcat . List.intersperse " "
	toList   = pure

-- * Class 'Attrify'
class Attrify a where
	attrify :: a -> H.AttributeValue
instance Attrify Char where
	attrify = fromString . pure
instance Attrify Text where
	attrify = fromString . Text.unpack
instance Attrify TL.Text where
	attrify = fromString . TL.unpack
instance Attrify Int where
	attrify = fromString . show
instance Attrify P.Pos where
	attrify = fromString . show . P.unPos
instance Attrify [Char] where
	attrify = 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 TL.Text where
	mayAttr _ "" = Nothing
	mayAttr a t  = Just (a $ fromString $ TL.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)
instance MayAttr AttributeValue where
	mayAttr a = Just . a

-- * Type 'ComposeState'
instance Semigroup (ComposeState st B.MarkupM a) where
	(<>) = (>>)
instance Monoid (ComposeState st B.MarkupM ()) where
	mempty  = pure ()
	mappend = (<>)
instance Monad (ComposeState st B.MarkupM) 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 -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.

-- * Type 'ComposeRWS'
instance Monoid w => Semigroup (ComposeRWS r w s B.MarkupM a) where
	(<>) = (>>)
instance Monoid w => Monoid (ComposeRWS r w s B.MarkupM ()) where
	mempty  = pure ()
	mappend = (<>)
instance Monoid w => Monad (ComposeRWS r w s B.MarkupM) 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 -- NOTE: impossible case, by definition of (>>=) on 'B.MarkupM'.

-- | Render some 'Markup' to a 'Builder'.
-- 
-- An 'IndentTag' is queried on each tag
-- to indent tags differently according to their names.
prettyMarkupBuilder :: (Text -> Bool) -> Markup -> Builder
prettyMarkupBuilder isInlinedElement ms = go (noIndent "" ms) "\n" mempty ms
	where
	inc :: Builder
	inc = "  "
	noIndent :: Text -> MarkupM b -> Bool
	noIndent e children =
		isInlinedElement e ||
		allInlined children && not (allComment children)
		where
		allInlined :: MarkupM b -> Bool
		allInlined = \case
		 Append x y -> allInlined x && allInlined y
		 CustomParent tag _m              -> isInlinedElement $ t_ChoiceString tag
		 CustomLeaf tag _close _          -> isInlinedElement $ t_ChoiceString tag
		 Parent tag _open _close _m       -> isInlinedElement $ getText tag
		 Leaf tag _begin _end _           -> isInlinedElement $ getText tag
		 AddAttribute _ _key _value m     -> allInlined m
		 AddCustomAttribute _key _value m -> allInlined m
		 Comment{} -> True
		 Content{} -> True
		 Empty{} -> True
		allComment :: MarkupM b -> Bool
		allComment = \case
		 Append x y -> allComment x && allComment y
		 AddAttribute _ _key _value m     -> allComment m
		 AddCustomAttribute _key _value m -> allComment m
		 Comment{} -> True
		 Empty{} -> True
		 _ -> False
	goAttrs :: Bool -> Builder -> Text -> [Builder] -> Builder
	goAttrs noInd ind t_tag attrs =
		case attrs of
		 [] -> mempty
		 [a] -> a
		 a0:as ->
			let ind_key = BS.fromString $ List.replicate (Text.length t_tag + 1) ' ' in
			let ind_attr = if noInd then mempty else ind<>ind_key in
			a0 <> foldMap (ind_attr <>) as
	go :: Bool -> Builder -> [Builder] -> MarkupM b -> Builder
	go noInd ind attrs = \case
	 Parent tag open close content ->
		let noInd' = noIndent (getText tag) content in
		(if noInd then mempty else ind)
		 <> BS.copyByteString (getUtf8ByteString open)
		 <> goAttrs noInd ind (getText tag) attrs
		 <> BS.fromChar '>'
		 <> go noInd' (if noInd then ind else ind<>inc) mempty content
		 <> (if noInd' then mempty else ind)
		 <> BS.copyByteString (getUtf8ByteString close)
	 CustomParent tag content ->
		let t_tag  = t_ChoiceString tag in
		let noInd' = noIndent t_tag content in
		(if noInd then mempty else ind)
		 <> BS.fromChar '<'
		 <> BS.fromText t_tag
		 <> goAttrs noInd ind t_tag attrs
		 <> BS.fromChar '>'
		 <> go noInd' (if noInd' then ind else ind<>inc) mempty content
		 <> (if noInd' then mempty else ind)
		 <> BS.fromByteString "</"
		 <> bs_ChoiceString tag
		 <> BS.fromChar '>'
	 Leaf tag begin end _ ->
		(if noInd then mempty else ind)
		 <> BS.copyByteString (getUtf8ByteString begin)
		 <> goAttrs noInd ind (getText tag) attrs
		 <> BS.copyByteString (getUtf8ByteString end)
	 CustomLeaf tag close _ ->
		let t_tag = t_ChoiceString tag in
		(if noInd then mempty else ind)
		 <> BS.fromChar '<'
		 <> BS.fromText t_tag
		 <> goAttrs noInd ind t_tag attrs
		 <> (if close then BS.fromByteString "/>" else BS.fromChar '>')
	 AddAttribute _ key value m ->
		go noInd ind
		 (  BS.copyByteString (getUtf8ByteString key)
		 <> bs_ChoiceString value
		 <> BS.fromChar '"'
		 : attrs ) m
	 AddCustomAttribute key value m ->
		go noInd ind
		 (  BS.fromChar ' '
		 <> bs_ChoiceString key
		 <> BS.fromByteString "=\""
		 <> bs_ChoiceString value
		 <> BS.fromChar '"'
		 : attrs ) m
	 Content c _ -> bs_ChoiceString c
	 Comment comment _ ->
		(if noInd then mempty else ind)
		 <> BS.fromByteString "<!--"
		 <> indentChoiceString (ind <> "    ") comment
		 <> (if noInd then mempty else ind)
		 <> BS.fromByteString "-->"
	 Append m1 m2 ->
		go noInd ind attrs m1 <>
		go noInd ind attrs m2
	 Empty _ -> mempty

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

prettyMarkupIO :: (Text -> Bool) -> (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 'txt' 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 #-}