Write.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
module 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(..), all)
import Data.Function (($), (.), const)
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 Symantic.XML.Document as XML

writeXML :: NoSource src => XMLs src -> TL.Text
writeXML xs = TLB.toLazyText $ write xs `R.runReader` def

writeXMLIndented :: NoSource src => TL.Text -> XMLs src -> TL.Text
writeXMLIndented ind xs =
	TLB.toLazyText $
	write xs `R.runReader` def
	 { reader_indent       = if TL.null ind then mempty else "\n"
	 , reader_indent_delta = ind
	 }

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 = (<>)
instance IsString Write where
	fromString = return . fromString

-- ** Type 'Reader'
data Reader = Reader
 { reader_ns_scope     :: Namespaces NCName
 , reader_indent       :: TLB.Builder
 , reader_indent_delta :: TL.Text
 , reader_no_text      :: Bool
 }
instance Default Reader where
	def = Reader
	 { reader_ns_scope     = def
	 , reader_indent       = ""
	 , reader_indent_delta = ""
	 , reader_no_text      = False
	 }

-- * 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 EscapedText where
	build (EscapedText et) = (`foldMap` et) $ \case
	 EscapedPlain     t -> build t
	 EscapedEntityRef r -> build r
	 EscapedCharRef   r -> build r

-- * Class 'Writable'
class Writeable a where
	write :: a -> Write
instance Writeable NCName where
	write = return . TLB.fromLazyText . unNCName
instance NoSource src => Writeable (XMLs src) where
	write xs = do
		ro <- R.ask
		if TL.null (reader_indent_delta ro)
		 then foldMap write xs
		 else
			R.local (const ro{reader_no_text}) $
				foldMap write xs
			where reader_no_text =
				(`all` xs) $ \case
				 Tree (Sourced _ (NodeText (EscapedText et))) _ts ->
					all (\case
					 EscapedPlain t -> TL.all Char.isSpace t
					 _ -> False) et
				 _ -> True
instance NoSource src => Writeable (XML src) where
	write (Tree (Sourced _src nod) xs) = do
		ro <- R.ask
		case nod of
			NodeAttr an
			 | [Tree (Sourced _ (NodeText av)) _] <- toList xs -> do
				return $ " "<>buildAttr (prefixifyQName (reader_ns_scope ro) an) av
			 | otherwise -> mempty
			NodeCDATA t ->
				return $
					reader_indent ro <>
					"<[CDATA[["<>build t<>"]]>"
			NodeComment t ->
				return $
					reader_indent ro <>
					"<!--"<>build t<>"-->"
			NodeElem elemQName -> do
				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
					 | qNameSpace elemQName == xmlns_empty = mempty
					 | otherwise                           = 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 = unescapeText 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 $ unescapeText 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 nor default,
					-- with fresh prefixes.
					HM.delete (namespaces_default declNS) $
					(`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 $ EscapedText $ pure $ EscapedPlain 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
					reader_indent ro
					 <> "<"<>build_elemPName
					 <> build_elemAttrs <>
					let build_elemChilds = write elemChilds
						`R.runReader` ro
						 { reader_ns_scope = scopeNS
						 , reader_indent   = reader_indent ro <> build (reader_indent_delta ro)
						 } in
					if null elemChilds
					then "/>"
					else ">"
						 <> build_elemChilds
						 <> (
							if TL.null (reader_indent_delta ro)
							|| noIndent elemChilds
							then mempty
							else reader_indent ro
						 )
						 <> "</"<>build_elemPName<>">"
					where
					noIndent =
						all $ \case
						 Tree (Sourced _ (NodeText _txt)) _ts -> True
						 _ -> False
			NodePI pn pv
			 | pn == "xml" -> do
				write_xs <- write xs
				return $
					"<?"<>build pn<>s<>write_xs<>"?>"
			 | otherwise ->
				return $
					reader_indent ro <>
					"<?"<>build pn<>s<>build pv<>"?>"
				where s | TL.null pv = ""
				        | otherwise  = " "
			NodeText t -> do
				return $
					if reader_no_text ro
					 then mempty
					 else build t

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

buildAttrValue :: EscapedText -> TLB.Builder
buildAttrValue (EscapedText et) = (`foldMap` et) $ \case
 EscapedPlain p -> build p
 EscapedEntityRef EntityRef{..} ->
	build $ TL.replace "\"" "&quot;" entityRef_value
 EscapedCharRef (CharRef c)
	| c == '\"' -> "&quot;"
	| otherwise -> build c

removeSpaces :: XMLs src -> XMLs src
removeSpaces xs =
	if (`all` xs) $ \case
	 Tree (Sourced _ (NodeText (EscapedText et))) _ts ->
		all (\case
		 EscapedPlain t -> TL.all Char.isSpace t
		 _ -> False) et
	 _ -> True
	then (`Seq.filter` xs) $ \case
		 Tree (Sourced _ NodeText{}) _ts -> False
		 _ -> True
	else xs