{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Symantic.XML.Write where

import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (Monad(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Traversable (Traversable(..))
import System.IO (IO, FilePath)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Char as Char
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Encoding as TL

import Language.Symantic.XML.Document as XML

writeXML :: XMLs -> TL.Text
writeXML x = TLB.toLazyText $ write x `R.runReader` Reader
 { reader_ns_scope = def
 }

writeFile :: FilePath -> TL.Text -> IO ()
writeFile fp t = BSL.writeFile fp $ TL.encodeUtf8 t

-- * Type 'Write'
type Write = R.Reader Reader TLB.Builder
instance Semigroup Write where
	(<>) = liftA2 (<>)
instance Monoid Write where
	mempty = return ""
	mappend = (<>)

-- ** Type 'Reader'
newtype Reader = Reader
 { reader_ns_scope :: Namespaces NCName
 }
instance IsString Write where
	fromString = return . fromString

-- * Class 'Buildable'
class Buildable a where
	build :: a -> TLB.Builder
instance Buildable Char.Char where
	build = TLB.singleton
instance Buildable String where
	build = TLB.fromString
instance Buildable TL.Text where
	build = TLB.fromLazyText
instance Buildable NCName where
	build = build . unNCName
instance Buildable Name where
	build = build . unName
instance Buildable PName where
	build PName{..} =
		case pNameSpace of
		 Nothing -> build pNameLocal
		 Just p -> build p<>":"<> build pNameLocal
instance Buildable Namespace where
	build = build . unNamespace
instance Buildable EntityRef where
	build EntityRef{..} = "&"<>build entityRef_name<>";"
instance Buildable CharRef where
	build (CharRef c) = "&#"<>build (show (Char.ord c))<>";"
instance Buildable Text where
	build = foldMap $ \case
	 TextLexemePlain     t -> build t
	 TextLexemeEntityRef r -> build r
	 TextLexemeCharRef   r -> build r

-- * Class 'Writable'
class Writeable a where
	write :: a -> Write
instance Writeable NCName where
	write = return . TLB.fromLazyText . unNCName
instance Writeable XMLs where
	write = foldMap write
instance Writeable XML where
	write (Tree (Sourced _src nod) xs) =
		case nod of
		 NodeElem elemQName -> do
			ro <- R.ask
			let (elemAttrs, elemChilds) =
				(`Seq.spanl` xs) $ \case
					 Tree (Sourced _ NodeAttr{}) _ -> True
					 _ -> False
			let (usedNS, declNS) ::
				( HS.HashSet Namespace
				, Namespaces NCName
				) =
				foldl' go (initUsedNS, initDeclNS) elemAttrs
				where
				initUsedNS = HS.singleton $ qNameSpace elemQName
				initDeclNS = def{namespaces_default = namespaces_default $ reader_ns_scope ro}
				go (!uNS, !dNS) = \case
				 Tree (Sourced _ (NodeAttr QName{..})) vs
				  -- xmlns:prefix="namespace"
				  | qNameSpace == xmlns_xmlns
				  , [Tree (Sourced _ (NodeText t)) _] <- toList vs ->
						let n = flatText t in
						(uNS,) dNS
						 { namespaces_prefixes =
							(if TL.null n
							then HM.delete
							-- NOTE: empty namespace means removal of the prefix from scope.
							else (`HM.insert` qNameLocal))
							 (Namespace n)
							 (namespaces_prefixes dNS)
						 }
				  -- xmlns="namespace"
				  | qNameSpace == xmlns_empty
				  , qNameLocal == NCName "xmlns"
				  , [Tree (Sourced _ (NodeText t)) _] <- toList vs ->
						(uNS,)
						dNS{namespaces_default = Namespace $ flatText t}
				  -- name="value"
				  | qNameSpace == xmlns_empty -> (uNS, dNS)
				  -- {namespace}name="value"
				  | otherwise -> (HS.insert qNameSpace uNS, dNS)
				 _ -> (uNS, dNS)
			let inhNS =
				-- NOTE: the inherited namespaces,
				-- including those declared at this element.
				HM.union
				 (namespaces_prefixes declNS)
				 (namespaces_prefixes (reader_ns_scope ro))
			let autoNS =
				-- NOTE: the namespaces used but not declared,
				-- with fresh prefixes.
				(`S.evalState` HS.empty) $
				traverse
				 (\() -> S.gets freshNCName)
				 (HS.toMap usedNS `HM.difference` inhNS)
			let autoAttrs =
				-- NOTE: XMLify autoNS
				HM.foldlWithKey' (\acc (Namespace v) p ->
					(acc Seq.|>) $
						Tree (notSourced $ NodeAttr QName{qNameSpace=xmlns_xmlns, qNameLocal=p}) $
							pure $ tree0 $ notSourced $ NodeText $ pure $ TextLexemePlain v
				 ) mempty autoNS
			let scopeNS = declNS { namespaces_prefixes = autoNS <> inhNS }
			return $
				let build_elemPName = build $ prefixifyQName scopeNS elemQName in
				let build_elemAttrs =
					(`foldMap` (autoAttrs <> elemAttrs)) $ \case
					 Tree (Sourced _ (NodeAttr an)) vs
					  | [Tree (Sourced _ (NodeText av)) _] <- toList vs ->
						" "<>buildAttr (prefixifyQName scopeNS{namespaces_default=""} an) av
					 _ -> mempty in
				"<"<>build_elemPName<>build_elemAttrs<>
				let build_elemChilds = write elemChilds
					`R.runReader` ro{reader_ns_scope = scopeNS} in
				if null elemChilds
				then "/>"
				else ">"<>build_elemChilds<>"</"<>build_elemPName<>">"
		 NodeAttr an
		  | [Tree (Sourced _ (NodeText av)) _] <- toList xs -> do
			ro <- R.ask
			return $ " "<>buildAttr (prefixifyQName (reader_ns_scope ro) an) av
		  | otherwise -> mempty
		 NodePI pn pv
		  | pn == "xml" -> do
			write_xs <- write xs
			return $ "<?"<>build pn<>s<>write_xs<>"?>"
		  | otherwise ->
			return $ "<?"<>build pn<>s<>build pv<>"?>"
			where s | TL.null pv = ""
			        | otherwise  = " "
		 NodeText    t -> return $ build t
		 NodeComment t -> return $ "<!--"<>build t<>"-->"
		 NodeCDATA   t -> return $ "<[CDATA[["<>build t<>"]]>"

buildAttr :: PName -> Text -> TLB.Builder
buildAttr n v = build n<>"=\""<>buildAttrValue v<>"\""

buildAttrValue :: Text -> TLB.Builder
buildAttrValue = foldMap $ \case
 TextLexemePlain p -> build p
 TextLexemeEntityRef EntityRef{..} ->
	build $ TL.replace "\"" "&quot;" entityRef_value
 TextLexemeCharRef (CharRef c)
	| c == '\"' -> "&quot;"
	| otherwise -> build c