Namespaces.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Symantic.RNC.Write.Namespaces where

import Control.Applicative (Applicative(..), Alternative(..), (<$>))
import Control.Monad (Monad(..), forM, sequence)
import Data.Default.Class (Default(..))
import Data.Function (($), (.), id)
import Data.Functor (Functor(..))
import Data.Maybe (Maybe(..), maybe, isNothing)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Text.Show (Show(..))
import Data.String (String)
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Control.Monad.Trans.State.Strict as S

import qualified Symantic.XML as XML
import Symantic.RNC.Sym

-- | Collect 'XML.Namespace's used and get them a dedicated prefix.
runNS :: forall a. [NS a] -> XML.Namespaces XML.NCName
runNS ns =
	namespaces
	 { XML.namespaces_prefixes =
		(`S.evalState` HS.empty) $
			let prefixesByNamespace =
				HM.delete "" $ -- NOTE: no prefix when there is no namespace.
				HM.update -- NOTE: no prefix when this is the default namespace.
				 (\p -> if isNothing p then Nothing else Just p)
				 (XML.namespaces_default namespaces) $
				XML.namespaces_prefixes namespaces in
			forM prefixesByNamespace $ \mp -> do
				usedPrefixes <- S.get
				let fp = maybe
					 (XML.freshNCName usedPrefixes)
					 (XML.freshifyNCName usedPrefixes)
					 mp
				S.modify' $ HS.insert fp
				return fp
	 }
	where
	namespaces :: XML.Namespaces (Maybe XML.NCName)
	namespaces = mconcat $ (`S.evalState` def) $ sequence $ unNS <$> ns

coerceNS :: NS a -> NS b
coerceNS = NS . unNS
{-# INLINE coerceNS #-}

-- * Type 'NS'
-- | Collect 'XML.Namespaces's and any prefixes associated with it,
-- using 'State' to avoid recurring into already visited 'rule's.
newtype NS a = NS { unNS :: S.State State (XML.Namespaces (Maybe XML.NCName)) }

-- ** Type 'State'
newtype State = State
 { state_rules :: {-!-}(HS.HashSet String)
 } deriving (Show)
instance Default State where
	def = State
	 { state_rules = HS.empty
	 }

instance Show (NS a) where
	showsPrec p = showsPrec p . runNS . pure
instance Semigroup (NS a) where
	NS x <> NS y = NS $ (<>) <$> x <*> y
instance Monoid (NS a) where
	mempty  = NS $ return mempty
	mappend = (<>)
instance Functor NS where
	fmap _f = coerceNS
instance Applicative NS where
	pure _ = mempty
	NS f <*> NS x = NS f <> NS x
	NS f <*  NS x = NS f <> NS x
	NS f  *> NS x = NS f <> NS x
instance Alternative NS where
	empty = mempty
	NS f <|> NS x = NS f <> NS x
	many = coerceNS
	some = coerceNS
instance Sym_Rule NS where
	rule n (NS ns) = NS $ do
		-- NOTE: avoid infinite loops
		-- by not reentering into already visited rules.
		st@State{..} <- S.get
		if HS.member n state_rules
		 then return mempty
		 else do
			S.put $ st{state_rules = HS.insert n state_rules}
			ns
	arg _n = mempty
type instance Permutation NS = NS
instance Sym_Permutation NS where
	runPermutation = coerceNS
	toPermutation = id
	toPermutationWithDefault _def = id
instance Sym_RNC NS where
	-- namespace n ns =
	-- 	NS $ return $ HM.singleton ns $ HS.singleton n
	namespace mp n =
		NS $ return $
		case mp of
		 Just p  -> XML.Namespaces{XML.namespaces_prefixes = HM.singleton n $ Just p, XML.namespaces_default = ""}
		 Nothing -> def{XML.namespaces_default = n}
	element XML.QName{..} (NS nsM) =
		NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
			HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
	attribute XML.QName{..} (NS nsM) =
		NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
			HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
	anyElem qNameSpace f =
		let NS nsM = f $ XML.NCName "*" in
		NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =
			HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}
	try         = id
	fail        = mempty
	escapedText = mempty
	text        = mempty
	any         = mempty
	choice      = mconcat
	option _def = coerceNS
	optional    = coerceNS
	manySeq     = coerceNS
	someSeq     = coerceNS