{-# LANGUAGE DeriveDataTypeable #-}

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.DOM.QualifiedName
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   The core data types of the HXT DOM.

-}

-- ------------------------------------------------------------

module Text.XML.HXT.DOM.QualifiedName
    ( QName
    , XName
    , NsEnv

    , mkQName
    , mkName
    , mkNsName
    , mkSNsName
    , mkPrefixLocalPart

    , equivQName
    , equivUri
    , equalQNameBy

    , namePrefix
    , localPart
    , namespaceUri

    , newXName
    , nullXName
    , isNullXName

    , mkQName'
    , namePrefix'
    , localPart'
    , namespaceUri'

    , setNamePrefix'
    , setLocalPart'
    , setNamespaceUri'

    , qualifiedName
    , universalName
    , universalUri
    , buildUniversalName

    , normalizeNsUri

    , setNamespace                      -- namespace related functions
    , isNCName
    , isWellformedQualifiedName
    , isWellformedQName
    , isWellformedNSDecl
    , isWellformedNameSpaceName
    , isNameSpaceName
    , isDeclaredNamespace

    , xmlNamespaceXName
    , xmlXName
    , xmlnsNamespaceXName
    , xmlnsXName
    , xmlnsQN

    , toNsEnv
    )

where

{-
import           Debug.Trace
 -}

import           Control.Arrow                  ( (***) )

import           Control.Concurrent.MVar
import           Control.Parallel.Strategies

import           Data.AssocList
import           Data.Char                      ( toLower )
import           Data.List                      ( isPrefixOf )
import qualified Data.Map               as M
import           Data.Maybe
import           Data.Typeable

import           System.IO.Unsafe               ( unsafePerformIO )

import           Text.XML.HXT.DOM.XmlKeywords   ( a_xml
                                                , a_xmlns
                                                , xmlNamespace
                                                , xmlnsNamespace
                                                )

import           Text.XML.HXT.DOM.Unicode       ( isXmlNCNameStartChar
                                                , isXmlNCNameChar
                                                )

-- -----------------------------------------------------------------------------

-- | XML names are represented by Strings, but these strings do not mix up with normal strings.
-- Names are always reduced to normal form, and they are stored internally in a name cache
-- for sharing equal names by the same data structure

type XName      = Atom

-- |
-- Namespace support for element and attribute names.
--
-- A qualified name consists of a name prefix, a local name
-- and a namespace uri.
-- All modules, which are not namespace aware, use only the 'localPart' component.
-- When dealing with namespaces, the document tree must be processed by 'Text.XML.HXT.Arrow.Namespace.propagateNamespaces'
-- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri

data QName      = LP ! XName
                | PX ! XName ! QName
                | NS ! XName ! QName
             deriving (Ord, Show, Read, Typeable)

-- |
-- Type for the namespace association list, used when propagating namespaces by
-- modifying the 'QName' values in a tree

type NsEnv = AssocList XName XName

-- -----------------------------------------------------------------------------

-- | Two QNames are equal if (1. case) namespaces are both empty and the qualified names
-- (prefix:localpart) are the same or (2. case) namespaces are set and namespaces and
-- local parts both are equal
    
instance Eq QName where
    (LP lp1)     == (LP lp2)            = lp1 == lp2
    (PX px1 qn1) == (PX px2 qn2)        = px1 == px2 && qn1== qn2
    (NS ns1 qn1) == (NS ns2 qn2)        = ns1 == ns2 && localPart' qn1 == localPart' qn2
    n1@(PX _ _)  == n2@(LP _)           = qualifiedName n1 == qualifiedName n2
    n1@(LP _)    == n2@(PX _ _)         = qualifiedName n1 == qualifiedName n2
    _            == _                   = False

-- the 4. and 5. rule are only neccessary when someone
-- uses XML names not in a systematical way
-- and does things like "mkName("x:y") == mkPrefixLocalPart("x","y")

instance NFData QName where

-- -----------------------------------------------------------------------------

newXName                :: String -> XName
newXName                = newAtom

isNullXName             :: XName -> Bool
isNullXName             = (== nullXName)

nullXName               :: XName
nullXName               = newXName ""

-- | access name prefix

namePrefix'             :: QName -> XName
namePrefix' (LP _)      = nullXName
namePrefix' (PX px _)   = px
namePrefix' (NS _ n)    = namePrefix' n

-- | access local part

localPart'              :: QName -> XName
localPart' (LP lp)      = lp
localPart' (PX _ n)     = localPart' n
localPart' (NS _ n)     = localPart' n

-- | access namespace uri

namespaceUri'           :: QName -> XName
namespaceUri' (NS ns _) = ns
namespaceUri' _         = nullXName

namePrefix              :: QName -> String
namePrefix              = show . namePrefix'

localPart               :: QName -> String
localPart               = show . localPart'

namespaceUri            :: QName -> String
namespaceUri            = show . namespaceUri'

-- ------------------------------------------------------------

-- | set name prefix

setNamespaceUri'                :: XName -> QName -> QName
setNamespaceUri' ns (NS _ n)    = if isNullXName ns
                                  then n
                                  else NS ns n
setNamespaceUri' ns n           = if isNullXName ns
                                  then n
                                  else NS ns n

-- | set local part

setLocalPart'                   :: XName -> QName -> QName
setLocalPart' lp (LP _)         = LP lp
setLocalPart' lp (PX px n)      = PX px (setLocalPart' lp n)
setLocalPart' lp (NS ns n)      = NS ns (setLocalPart' lp n)

-- | set name prefix

setNamePrefix'                  :: XName -> QName -> QName
setNamePrefix' px (PX _ n)      = if px == nullXName
                                  then n
                                  else PX px n
setNamePrefix' px n@(LP _)      = if px == nullXName
                                  then n
                                  else PX px n
setNamePrefix' px (NS ns n)     = NS ns (setNamePrefix' px n)


-- ------------------------------------------------------------

-- |
-- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result

qualifiedName                   :: QName -> String
qualifiedName (LP lp)           = show lp
qualifiedName (PX px n)         = show px ++ (':' : qualifiedName n)
qualifiedName (NS _ n)          = qualifiedName n

-- |
-- builds the \"universal\" name, that is the namespace uri surrounded with \"{\" and \"}\" followed by the local part
-- (specialisation of 'buildUniversalName')

universalName                   :: QName -> String
universalName                   = buildUniversalName (\ ns lp -> '{' : ns ++ '}' : lp)

-- |
-- builds an \"universal\" uri, that is the namespace uri followed by the local part. This is usefull for RDF applications,
-- where the subject, predicate and object often are concatenated from namespace uri and local part
-- (specialisation of 'buildUniversalName')

universalUri                    :: QName -> String
universalUri                    = buildUniversalName (++)

-- |
-- builds a string from the namespace uri and the local part. If the namespace uri is empty, the local part is returned, else
-- namespace uri and local part are combined with the combining function given by the first parameter

buildUniversalName              :: (String -> String -> String) -> QName -> String
buildUniversalName bf (NS ns n) = show ns `bf` localPart n
buildUniversalName _  n         = localPart n

-- ------------------------------------------------------------
--
-- internal XName functions

mkQName'                        :: XName -> XName -> XName -> QName
mkQName' px lp ns
    | isNullXName ns            =       px_lp
    | otherwise                 = NS ns px_lp
    where
    px_lp
        | isNullXName px        = LP lp
        | otherwise             = PX px (LP lp)

-- ------------------------------------------------------------

-- |
-- constructs a simple name, with prefix and localPart but without a namespace uri.
--
-- see also 'mkQName', 'mkName'

mkPrefixLocalPart               :: String -> String -> QName
mkPrefixLocalPart px lp
    | null px                   =                  n1
    | otherwise                 = PX (newXName px) n1
    where
    n1 = LP (newXName lp)

-- |
-- constructs a simple, namespace unaware name.
-- If the name is in @prefix:localpart@ form and the prefix is not empty
-- the name is split internally into
-- a prefix and a local part.

mkName                          :: String -> QName
mkName n                        
    | (':' `elem` n)
      &&
      not (null px)			-- more restrictive: isWellformedQualifiedName n
                                = mkPrefixLocalPart px lp
    | otherwise                 = mkPrefixLocalPart "" n
    where
    (px, (_:lp)) = span (/= ':') n

-- |
-- constructs a complete qualified name with 'namePrefix', 'localPart' and 'namespaceUri'.
-- This function can be used to build not wellformed prefix:localpart names.
-- The XPath module uses wildcard names like @xxx:*@. These must be build with 'mkQName'
-- and not with mkName.

mkQName                         :: String -> String -> String -> QName
mkQName px lp ns
    | null ns                   =                  n1
    | otherwise                 = NS (newXName ns) n1
    where
    n1 = mkPrefixLocalPart px lp

-- ------------------------------------------------------------

-- |
-- old name for 'mkName'

mkSNsName                       :: String -> QName
mkSNsName                       = mkName

-- |
-- constructs a simple, namespace aware name, with prefix:localPart as first parameter,
-- namspace uri as second.
--
-- see also 'mkName', 'mkPrefixLocalPart'

mkNsName                        :: String -> String -> QName
mkNsName n ns
    | null ns                   =                   mkName n
    | otherwise                 = NS (newXName ns) (mkName n)

-- ------------------------------------------------------------

-- | Equivalent QNames are defined as follows: The URIs are normalized before comparison.
-- Comparison is done with 'equalQNameBy' and 'equivUri'

equivQName                      :: QName -> QName -> Bool
equivQName                      = equalQNameBy equivUri

-- | Comparison of normalized namespace URIs using 'normalizeNsUri'

equivUri                        :: String -> String -> Bool
equivUri x y                    = normalizeNsUri x == normalizeNsUri y

-- | Sometimes a weaker equality relation than 'equalQName' is appropriate, e.g no case significance in names, ...
-- a name normalization function can be applied to the strings before comparing. Called by 'equalQName' and
-- 'equivQName'

equalQNameBy                    :: (String -> String -> Bool) -> QName -> QName -> Bool
equalQNameBy equiv q1 q2        = localPart q1 == localPart q2
                                  &&
                                  (namespaceUri q1 `equiv` namespaceUri q2)

-- |  Normalization of URIs: Normalization is done by conversion into lowercase letters. A trailing \"\/\" is ignored

normalizeNsUri                  :: String -> String
normalizeNsUri                  = map toLower . stripSlash
    where
    stripSlash ""               = ""
    stripSlash s
        | last s == '/'         = init s
        | otherwise             = s

-- -----------------------------------------------------------------------------

-- Namespace predicates

-- |
-- Compute the name prefix and the namespace uri for a qualified name.
--
-- This function does not test whether the name is a wellformed qualified name.
-- see Namespaces in XML Rule [6] to [8]. Error checking is done with separate functions,
-- see 'isWellformedQName' and 'isWellformedQualifiedName' for error checking.

setNamespace                    :: NsEnv -> QName -> QName
setNamespace env n@(PX px _)    = attachNS env px        n              -- none empty prefix found
setNamespace env n@(LP _)       = attachNS env nullXName n              -- use default namespace uri
setNamespace env (NS _ n)       = setNamespace env n

attachNS                        :: NsEnv -> XName -> QName -> QName
attachNS env px n1              = maybe n1 (\ ns -> NS ns n1) . lookup px $ env

xmlnsNamespaceXName             :: XName
xmlnsNamespaceXName             = newXName xmlnsNamespace

xmlnsXName                      :: XName
xmlnsXName                      = newXName a_xmlns

xmlnsQN                         :: QName
xmlnsQN                         = NS xmlnsNamespaceXName (LP xmlnsXName)

xmlNamespaceXName               :: XName
xmlNamespaceXName               = newXName xmlNamespace

xmlXName                        :: XName
xmlXName                        = newXName a_xml

-- -----------------------------------------------------------------------------
--

-- |
-- test for wellformed NCName, rule [4] XML Namespaces

isNCName                        :: String -> Bool
isNCName []                     = False
isNCName n                      = and ( zipWith ($)
                                        (isXmlNCNameStartChar : repeat isXmlNCNameChar)
                                        n
                                      )

-- |
-- test for wellformed QName, rule [6] XML Namespaces
-- predicate is used in filter 'valdateNamespaces'.

isWellformedQualifiedName       :: String -> Bool
isWellformedQualifiedName s
    | null lp                   = isNCName px
    | otherwise                 = isNCName px && isNCName (tail lp)
    where
    (px, lp)                    = span (/= ':') s

-- |
-- test for wellformed QName values.
-- A QName is wellformed, if the local part is a NCName, the namePrefix, if not empty, is also a NCName.
-- predicate is used in filter 'valdateNamespaces'.

isWellformedQName               :: QName -> Bool
isWellformedQName (LP lp)       = isNCName . show $ lp                          -- rule [8] XML Namespaces
isWellformedQName (PX px n)     = (isNCName . show) px                          -- rule [7] XML Namespaces
                                  &&
                                  isWellformedQName n
isWellformedQName (NS _ n)      = isWellformedQName n

-- |
-- test whether an attribute name is a namesapce declaration name.
-- If this is not the case True is the result, else
-- the name must be a well formed namespace name:
-- All namespace prefixes starting with \"xml\" are reserved for XML related definitions.
-- predicate is used in filter 'valdateNamespaces'.

isWellformedNSDecl              :: QName -> Bool
isWellformedNSDecl n            = not (isNameSpaceName n)
                                  ||
                                  isWellformedNameSpaceName n

-- |
-- test for a namespace name to be well formed

isWellformedNameSpaceName               :: QName -> Bool
isWellformedNameSpaceName (LP lp)       = lp == xmlnsXName
isWellformedNameSpaceName (PX px n)     = px == xmlnsXName
                                          &&
                                          not (null lp')
                                          &&
                                          not (a_xml `isPrefixOf` lp')
                                          where
                                          lp' = localPart n
isWellformedNameSpaceName (NS _ n)      = isWellformedNSDecl n

-- |
-- test whether a name is a namespace declaration attribute name

isNameSpaceName                 :: QName -> Bool
isNameSpaceName (LP lp)         = lp == xmlnsXName
isNameSpaceName (PX px _)       = px == xmlnsXName
isNameSpaceName (NS _  n)       = isNameSpaceName n

-- |
-- 
-- predicate is used in filter 'valdateNamespaces'.

isDeclaredNamespace             :: QName -> Bool
isDeclaredNamespace (NS ns n)   = isNS ns        n
isDeclaredNamespace        n    = isNS nullXName n

isNS                            :: XName -> QName -> Bool
isNS _  (LP _)                  = True                          -- no namespace used
isNS ns (PX px _)
    | px == xmlnsXName          = ns == xmlnsNamespaceXName     -- "xmlns" has a predefined namespace uri
    | px == xmlXName            = ns == xmlNamespaceXName       -- "xml" has a predefiend namespace"
    | otherwise                 = ns /= nullXName               -- namespace values are not empty
isNS ns (NS _ n)                = isNS ns n                     -- this does not occur, but warning is prevented

-- -----------------------------------------------------------------------------

toNsEnv                         :: AssocList String String -> NsEnv
toNsEnv                         = map (newXName *** newXName)

-- -----------------------------------------------------------------------------

-- the name cache, same implementation strategy as in Data.Atom,
-- but conversion to and from ByteString prevented

type Atoms      = M.Map String String

newtype Atom    = A String
                  deriving (Eq, Ord, Typeable)

-- ------------------------------------------------------------

-- | the internal cache for the strings

theAtoms        :: MVar Atoms
theAtoms        = unsafePerformIO (newMVar M.empty)
{-# NOINLINE theAtoms #-}

-- | insert a bytestring into the atom cache

insertAtom      :: String -> Atoms -> (Atoms, Atom)
insertAtom s m  = maybe (M.insert {- (trace (show s) s) -} s s m, A s `demanding` rnf s)
                        (\ s' -> (m, A s'))
                  .
                  M.lookup s $ m

-- | creation of an @Atom@ from a @String@

newAtom         :: String -> Atom
newAtom         = unsafePerformIO . newAtom'
{-# NOINLINE newAtom #-}

-- | The internal operation running in the IO monad
newAtom'        :: String -> IO Atom
newAtom' s      = do
                  m <- takeMVar theAtoms
                  let (m', a) = insertAtom s m
                  putMVar theAtoms m'
                  return a

instance Read Atom where
    readsPrec p str = [ (newAtom x, y) | (x, y) <- readsPrec p str ]

instance Show Atom where
    show (A s)  = s

instance NFData Atom where

-----------------------------------------------------------------------------