{-# 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