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
, isNCName
, isWellformedQualifiedName
, isWellformedQName
, isWellformedNSDecl
, isWellformedNameSpaceName
, isNameSpaceName
, isDeclaredNamespace
, xmlNamespaceXName
, xmlXName
, xmlnsNamespaceXName
, xmlnsXName
, xmlnsQN
, toNsEnv
)
where
import Control.Arrow ( (***) )
import Control.Concurrent.MVar
import Control.DeepSeq
import Data.AssocList
import Data.Char ( toLower )
import Data.List ( isPrefixOf )
import qualified Data.Map as M
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
)
type XName = Atom
data QName = LP ! XName
| PX ! XName ! QName
| NS ! XName ! QName
deriving (Ord, Show, Read, Typeable)
type NsEnv = AssocList XName XName
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
instance NFData QName where
newXName :: String -> XName
newXName = newAtom
isNullXName :: XName -> Bool
isNullXName = (== nullXName)
nullXName :: XName
nullXName = newXName ""
namePrefix' :: QName -> XName
namePrefix' (LP _) = nullXName
namePrefix' (PX px _) = px
namePrefix' (NS _ n) = namePrefix' n
localPart' :: QName -> XName
localPart' (LP lp) = lp
localPart' (PX _ n) = localPart' n
localPart' (NS _ n) = localPart' n
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'
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
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)
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)
qualifiedName :: QName -> String
qualifiedName (LP lp) = show lp
qualifiedName (PX px n) = show px ++ (':' : qualifiedName n)
qualifiedName (NS _ n) = qualifiedName n
universalName :: QName -> String
universalName = buildUniversalName (\ ns lp -> '{' : ns ++ '}' : lp)
universalUri :: QName -> String
universalUri = buildUniversalName (++)
buildUniversalName :: (String -> String -> String) -> QName -> String
buildUniversalName bf (NS ns n) = show ns `bf` localPart n
buildUniversalName _ n = localPart n
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)
mkPrefixLocalPart :: String -> String -> QName
mkPrefixLocalPart px lp
| null px = n1
| otherwise = PX (newXName px) n1
where
n1 = LP (newXName lp)
mkName :: String -> QName
mkName n
| (':' `elem` n)
&&
not (null px)
= mkPrefixLocalPart px lp
| otherwise = mkPrefixLocalPart "" n
where
(px, (_:lp)) = span (/= ':') n
mkQName :: String -> String -> String -> QName
mkQName px lp ns
| null ns = n1
| otherwise = NS (newXName ns) n1
where
n1 = mkPrefixLocalPart px lp
mkSNsName :: String -> QName
mkSNsName = mkName
mkNsName :: String -> String -> QName
mkNsName n ns
| null ns = mkName n
| otherwise = NS (newXName ns) (mkName n)
equivQName :: QName -> QName -> Bool
equivQName = equalQNameBy equivUri
equivUri :: String -> String -> Bool
equivUri x y = normalizeNsUri x == normalizeNsUri y
equalQNameBy :: (String -> String -> Bool) -> QName -> QName -> Bool
equalQNameBy equiv q1 q2 = localPart q1 == localPart q2
&&
(namespaceUri q1 `equiv` namespaceUri q2)
normalizeNsUri :: String -> String
normalizeNsUri = map toLower . stripSlash
where
stripSlash "" = ""
stripSlash s
| last s == '/' = init s
| otherwise = s
setNamespace :: NsEnv -> QName -> QName
setNamespace env n@(PX px _) = attachNS env px n
setNamespace env n@(LP _) = attachNS env nullXName n
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
isNCName :: String -> Bool
isNCName [] = False
isNCName n = and ( zipWith ($)
(isXmlNCNameStartChar : repeat isXmlNCNameChar)
n
)
isWellformedQualifiedName :: String -> Bool
isWellformedQualifiedName s
| null lp = isNCName px
| otherwise = isNCName px && isNCName (tail lp)
where
(px, lp) = span (/= ':') s
isWellformedQName :: QName -> Bool
isWellformedQName (LP lp) = isNCName . show $ lp
isWellformedQName (PX px n) = (isNCName . show) px
&&
isWellformedQName n
isWellformedQName (NS _ n) = isWellformedQName n
isWellformedNSDecl :: QName -> Bool
isWellformedNSDecl n = not (isNameSpaceName n)
||
isWellformedNameSpaceName n
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
isNameSpaceName :: QName -> Bool
isNameSpaceName (LP lp) = lp == xmlnsXName
isNameSpaceName (PX px _) = px == xmlnsXName
isNameSpaceName (NS _ n) = isNameSpaceName n
isDeclaredNamespace :: QName -> Bool
isDeclaredNamespace (NS ns n) = isNS ns n
isDeclaredNamespace n = isNS nullXName n
isNS :: XName -> QName -> Bool
isNS _ (LP _) = True
isNS ns (PX px _)
| px == xmlnsXName = ns == xmlnsNamespaceXName
| px == xmlXName = ns == xmlNamespaceXName
| otherwise = ns /= nullXName
isNS ns (NS _ n) = isNS ns n
toNsEnv :: AssocList String String -> NsEnv
toNsEnv = map (newXName *** newXName)
type Atoms = M.Map String String
newtype Atom = A String
deriving (Eq, Ord, Typeable)
theAtoms :: MVar Atoms
theAtoms = unsafePerformIO (newMVar M.empty)
insertAtom :: String -> Atoms -> (Atoms, Atom)
insertAtom s m = maybe (M.insert s s m, deepseq s (A s))
(\ s' -> (m, A s'))
.
M.lookup s $ m
newAtom :: String -> Atom
newAtom = unsafePerformIO . newAtom'
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