hxt-8.3.0: src/Text/XML/HXT/DOM/QualifiedName.hs
-- ------------------------------------------------------------
{- |
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 "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
-----------------------------------------------------------------------------