hxt-9.1.0: src/Text/XML/HXT/DOM/QualifiedName.hs
{-# LANGUAGE DeriveDataTypeable #-}
-- ------------------------------------------------------------
{- |
Module : Text.XML.HXT.DOM.QualifiedName
Copyright : Copyright (C) 2011 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : stable
Portability: portable
The types and functions for qualified names
-}
-- ------------------------------------------------------------
module Text.XML.HXT.DOM.QualifiedName
( QName
, XName(unXN)
, NsEnv
, mkQName
, mkName
, mkNsName
, mkSNsName
, mkPrefixLocalPart
, equivQName
, equivUri
, equalQNameBy
, namePrefix
, localPart
, namespaceUri
, newXName
, nullXName
, isNullXName
, newQName
, mkQName'
, namePrefix'
, localPart'
, namespaceUri'
, setNamePrefix'
, setLocalPart'
, setNamespaceUri'
, qualifiedName
, 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.DeepSeq
import Control.FlatSeq
import Data.AssocList
import Data.Binary
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 Data.Char.Properties.XMLCharProps ( 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
data XName = XN { _idXN :: ! Int -- for optimization of equality test, see Eq instance
, unXN :: String
}
deriving (Typeable)
instance Eq XName where
(XN id1 _) == (XN id2 _) = id1 == id2
instance Ord XName where
compare (XN _ n1) (XN _ n2) = compare n1 n2
{-
instance Read XName where
readsPrec p str = [ (newXName x, y) | (x, y) <- readsPrec p str ]
instance Show XName where
show (XN _ s) = show s
-}
instance NFData XName where
rnf (XN _ s) = rnf s
instance WNFData XName where
rwnf (XN _ s) = rnf s
instance Binary XName where
put (XN _ s) = put s
get = do
s <- get
return $! newXName s
-----------------------------------------------------------------------------
-- |
-- Type for the namespace association list, used when propagating namespaces by
-- modifying the 'QName' values in a tree
type NsEnv = AssocList XName XName
-----------------------------------------------------------------------------
-- |
-- 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 = QN { localPart' :: ! XName
, namePrefix' :: ! XName
, namespaceUri' :: ! XName
}
deriving (Typeable)
-- -----------------------------------------------------------------------------
-- | 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 are equal
instance Eq QName where
(QN lp1 px1 ns1) == (QN lp2 px2 ns2)
| ns1 /= ns2 = False -- namespaces are set and differ
| not (isNullXName ns1) = lp1 == lp2 -- namespaces are set and are equal: local parts must be equal
| otherwise = lp1 == lp2 -- no namespaces are set: local parts must be equal
&& -- and prefixes are not set or they are equal
px1 == px2
instance NFData QName
instance WNFData QName
instance Show QName where
show = showQN
-- -----------------------------------------------------------------------------
instance Binary QName where
put (QN lp px ns) = put (unXN px) >>
put (unXN lp) >>
put (unXN ns)
get = do
px <- get
lp <- get
ns <- get
return $! newNsName lp px ns
-- ^^
-- strict apply !!!
-- build the QNames strict, else the name sharing optimization will not be in effect
-- -----------------------------------------------------------------------------
isNullXName :: XName -> Bool
isNullXName = (== nullXName)
{-# INLINE isNullXName #-}
namePrefix :: QName -> String
namePrefix = unXN . namePrefix'
{-# INLINE namePrefix #-}
localPart :: QName -> String
localPart = unXN . localPart'
{-# INLINE localPart #-}
namespaceUri :: QName -> String
namespaceUri = unXN . namespaceUri'
{-# INLINE namespaceUri #-}
-- ------------------------------------------------------------
-- | set name prefix
setNamespaceUri' :: XName -> QName -> QName
setNamespaceUri' ns (QN lp px _ns) = newQName lp px ns
-- | set local part
setLocalPart' :: XName -> QName -> QName
setLocalPart' lp (QN _lp px ns) = newQName lp px ns
-- | set name prefix
setNamePrefix' :: XName -> QName -> QName
setNamePrefix' px (QN lp _px ns) = newQName lp px ns
-- ------------------------------------------------------------
-- |
-- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result
qualifiedName :: QName -> String
qualifiedName (QN lp px _ns)
| isNullXName px = unXN lp
| otherwise = unXN px ++ (':' : unXN lp)
-- | functional list version of qualifiedName used in xshow
qualifiedName' :: QName -> String -> String
qualifiedName' (QN lp px _ns)
| isNullXName px = (unXN lp ++)
| otherwise = (unXN px ++) . (':' :) . (unXN lp ++)
-- |
-- 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 n@(QN _lp _px ns)
| isNullXName ns = localPart n
| otherwise = unXN ns `bf` localPart n
showQN :: QName -> String
showQN n
| null ns = show $ qualifiedName n
| otherwise = show $ "{" ++ ns ++ "}" ++ qualifiedName n
where
ns = namespaceUri n
-- ------------------------------------------------------------
--
-- internal XName functions
mkQName' :: XName -> XName -> XName -> QName
mkQName' px lp ns = newQName lp px ns
{-# DEPRECATED mkQName' "use newQName instead with lp px ns param seq " #-}
-- ------------------------------------------------------------
-- |
-- 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 = newLpName lp
| otherwise = newPxName lp px
-- |
-- 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
= newPxName lp px
| otherwise = newLpName 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 = mkPrefixLocalPart px lp
| otherwise = newNsName lp px ns
-- ------------------------------------------------------------
-- |
-- old name for 'mkName'
mkSNsName :: String -> QName
mkSNsName = mkName
{-# DEPRECATED mkSNsName "use mkName instead" #-}
-- |
-- 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 = trace ("mkNsName: " ++ show n ++ " " ++ show ns) (mkNsName' n ns)
-}
mkNsName :: String -> String -> QName
mkNsName n ns
| null ns = qn
| otherwise = setNamespaceUri' ns' qn
where
qn = mkName n
ns' = newXName ns
-- ------------------------------------------------------------
-- | 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@(QN lp px _ns)
= maybe n (\ ns -> newQName lp px ns) . lookup px $ env
-- -----------------------------------------------------------------------------
--
-- |
-- 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 (QN lp px _ns)
= (isNCName . unXN) lp -- rule [8] XML Namespaces
&&
( isNullXName px
||
(isNCName . unXN) px -- rule [7] XML Namespaces
)
-- |
-- 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 n@(QN lp px _ns)
| isNullXName px = lp == xmlnsXName
| otherwise = px == xmlnsXName
&&
not (null lp')
&&
not (a_xml `isPrefixOf` lp')
where
lp' = localPart n
-- |
-- test whether a name is a namespace declaration attribute name
isNameSpaceName :: QName -> Bool
isNameSpaceName (QN lp px _ns)
| isNullXName px = lp == xmlnsXName
| otherwise = px == xmlnsXName
-- |
--
-- predicate is used in filter 'valdateNamespaces'.
isDeclaredNamespace :: QName -> Bool
isDeclaredNamespace (QN _lp px ns)
| isNullXName px = True -- no namespace used
| px == xmlnsXName = ns == xmlnsNamespaceXName -- "xmlns" has a predefined namespace uri
| px == xmlXName = ns == xmlNamespaceXName -- "xml" has a predefiend namespace"
| otherwise = not (isNullXName ns) -- namespace values are not empty
-- -----------------------------------------------------------------------------
toNsEnv :: AssocList String String -> NsEnv
toNsEnv = map (newXName *** newXName)
-- -----------------------------------------------------------------------------
-- the name and string cache
data NameCache = NC { _newXN :: ! Int -- next free name id
, _xnCache :: ! (M.Map String XName)
, _qnCache :: ! (M.Map (XName, XName, XName) QName) -- we need another type than QName
} -- for the key because of the unusable
-- Eq instance of QName
type ChangeNameCache r = NameCache -> (NameCache, r)
-- ------------------------------------------------------------
-- | the internal cache for QNames (and name strings)
theNameCache :: MVar NameCache
theNameCache = unsafePerformIO (newMVar $ initialCache)
{-# NOINLINE theNameCache #-}
initialXNames :: [XName]
nullXName
, xmlnsNamespaceXName
, xmlnsXName
, xmlNamespaceXName
, xmlXName :: XName
initialXNames@
[ nullXName
, xmlnsNamespaceXName
, xmlnsXName
, xmlNamespaceXName
, xmlXName
] = zipWith XN [0..] $
[ ""
, xmlnsNamespace
, a_xmlns
, xmlNamespace
, a_xml
]
initialQNames :: [QName]
xmlnsQN :: QName
initialQNames@
[xmlnsQN] = [QN xmlnsXName nullXName xmlnsNamespaceXName]
initialCache :: NameCache
initialCache = NC
(length initialXNames)
(M.fromList $ map (\ xn -> (unXN xn, xn)) initialXNames)
(M.fromList $ map (\ qn@(QN lp px ns) -> ((lp, px, ns), qn)) initialQNames)
-- ------------------------------------------------------------
changeNameCache :: NFData r => ChangeNameCache r -> r
changeNameCache action = unsafePerformIO changeNameCache'
where
changeNameCache' = do
-- putStrLn "takeMVar"
c <- takeMVar theNameCache
let (c', res) = action c
c' `seq` -- rnf res `seq`
putMVar theNameCache c'
-- putStrLn "putMVar"
return res
{-# NOINLINE changeNameCache #-}
newXName' :: String -> ChangeNameCache XName
newXName' n c@(NC nxn xm qm)
= case M.lookup n xm of
Just xn -> (c, xn)
Nothing -> let nxn' = nxn + 1 in
let xn = (XN nxn n) in
let xm' = M.insert n xn xm in
-- trace ("newXName: XN " ++ show nxn ++ " " ++ show n) $
rnf xn `seq` (NC nxn' xm' qm, xn)
newQName' :: XName -> XName -> XName -> ChangeNameCache QName
newQName' lp px ns c@(NC nxn xm qm)
= case M.lookup q' qm of
Just qn -> -- trace ("oldQName: " ++ show qn) $ -- log evaluation sequence
(c, qn)
Nothing -> let qm' = M.insert q' q qm in
-- trace ("newQName: " ++ show q) $ -- log insertion of a new QName
q `seq` (NC nxn xm qm', q)
where
q' = (lp, px, ns)
q = QN lp px ns
andThen :: ChangeNameCache r1 ->
(r1 -> ChangeNameCache r2) -> ChangeNameCache r2
andThen a1 a2 c0 = let (c1, r1) = a1 c0 in
(a2 r1) c1
newXName :: String -> XName
newXName n = changeNameCache $
newXName' n
newQName :: XName -> XName -> XName -> QName
newQName lp px ns = lp `seq` px `seq` ns `seq` -- XNames must be evaluated, else MVar blocks
( changeNameCache $
newQName' lp px ns
)
newLpName :: String -> QName
newLpName lp = changeNameCache $
newXName' lp `andThen` \ lp' ->
newQName' lp' nullXName nullXName
newPxName :: String -> String -> QName
newPxName lp px = changeNameCache $
newXName' lp `andThen` \ lp' ->
newXName' px `andThen` \ px' ->
newQName' lp' px' nullXName
newNsName :: String -> String -> String -> QName
newNsName lp px ns = changeNameCache $
newXName' lp `andThen` \ lp' ->
newXName' px `andThen` \ px' ->
newXName' ns `andThen` \ ns' ->
newQName' lp' px' ns'
-----------------------------------------------------------------------------