{-# 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.DeepSeq
import           Control.FlatSeq

import           Data.AssocList
import           Data.Binary
import           Data.Char                         (toLower)
import           Data.IORef
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 (isXmlNCNameChar,
                                                    isXmlNCNameStartChar)

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

-- | 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 { XName -> Int
_idXN :: !Int        -- for optimization of equality test, see Eq instance
                                     ,  XName -> String
unXN ::   String
                                     }
                                  deriving (Typeable)

instance Eq XName where
    (XN Int
id1 String
_) == :: XName -> XName -> Bool
== (XN Int
id2 String
_)    = Int
id1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
id2

instance Ord XName where
    compare :: XName -> XName -> Ordering
compare (XN Int
_ String
n1) (XN Int
_ String
n2) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
n1 String
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 :: XName -> ()
rnf (XN Int
_ String
s)                = String -> ()
forall a. NFData a => a -> ()
rnf String
s

instance WNFData XName where
    rwnf :: XName -> ()
rwnf (XN Int
_ String
s)               = String -> ()
forall a. NFData a => a -> ()
rnf String
s

instance Binary XName where
    put :: XName -> Put
put (XN Int
_ String
s)                = String -> Put
forall t. Binary t => t -> Put
put String
s
    get :: Get XName
get                         = do
                                  String
s <- Get String
forall t. Binary t => Get t
get
                                  XName -> Get XName
forall (m :: * -> *) a. Monad m => a -> m a
return (XName -> Get XName) -> XName -> Get XName
forall a b. (a -> b) -> a -> b
$! String -> XName
newXName String
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 { QName -> XName
localPart'    :: !XName
                     , QName -> XName
namePrefix'   :: !XName
                     , QName -> 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 XName
lp1 XName
px1 XName
ns1) == :: QName -> QName -> Bool
== (QN XName
lp2 XName
px2 XName
ns2)
        | XName
ns1 XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
/= XName
ns2            = Bool
False                 -- namespaces are set and differ
        | Bool -> Bool
not (XName -> Bool
isNullXName XName
ns1) = XName
lp1 XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
lp2            -- namespaces are set and are equal: local parts must be equal
        | Bool
otherwise             = XName
lp1 XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
lp2            -- no namespaces are set: local parts must be equal
                                  Bool -> Bool -> Bool
&&                    -- and prefixes are not set or they are equal
                                  XName
px1 XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
px2

instance Ord QName where
  compare :: QName -> QName -> Ordering
compare (QN XName
lp1 XName
px1 XName
ns1) (QN XName
lp2 XName
px2 XName
ns2)
      | XName -> Bool
isNullXName XName
ns1 Bool -> Bool -> Bool
&& XName -> Bool
isNullXName XName
ns2              -- no namespaces set: px is significant
          = (XName, XName) -> (XName, XName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (XName
px1, XName
lp1) (XName
px2, XName
lp2)
      | Bool
otherwise                                       -- namespace aware cmp: ns is significant, px is irrelevant
          = (XName, XName) -> (XName, XName) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (XName
lp1, XName
ns1) (XName
lp2, XName
ns2)

instance NFData  QName where
    rnf :: QName -> ()
rnf QName
x = QName -> () -> ()
seq QName
x ()

instance WNFData QName

instance Show QName where
    show :: QName -> String
show = QName -> String
showQN

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

instance Binary QName where
    put :: QName -> Put
put (QN XName
lp XName
px XName
ns)   = String -> Put
forall t. Binary t => t -> Put
put (XName -> String
unXN XName
px) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                          String -> Put
forall t. Binary t => t -> Put
put (XName -> String
unXN XName
lp) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                          String -> Put
forall t. Binary t => t -> Put
put (XName -> String
unXN XName
ns)
    get :: Get QName
get                 = do
                          String
px <- Get String
forall t. Binary t => Get t
get
                          String
lp <- Get String
forall t. Binary t => Get t
get
                          String
ns <- Get String
forall t. Binary t => Get t
get
                          QName -> Get QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> Get QName) -> QName -> Get QName
forall a b. (a -> b) -> a -> b
$! String -> String -> String -> QName
newNsName String
lp String
px String
ns
                          --     ^^
                          -- strict apply !!!
                          -- build the QNames strict, else the name sharing optimization will not be in effect

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

isNullXName             :: XName -> Bool
isNullXName :: XName -> Bool
isNullXName             = (XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
nullXName)
{-# INLINE isNullXName #-}

namePrefix              :: QName -> String
namePrefix :: QName -> String
namePrefix              = XName -> String
unXN (XName -> String) -> (QName -> XName) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> XName
namePrefix'
{-# INLINE namePrefix #-}

localPart               :: QName -> String
localPart :: QName -> String
localPart               = XName -> String
unXN (XName -> String) -> (QName -> XName) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> XName
localPart'
{-# INLINE localPart #-}

namespaceUri            :: QName -> String
namespaceUri :: QName -> String
namespaceUri            = XName -> String
unXN (XName -> String) -> (QName -> XName) -> QName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> XName
namespaceUri'
{-# INLINE namespaceUri #-}

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

-- | set name prefix

setNamespaceUri'                        :: XName -> QName -> QName
setNamespaceUri' :: XName -> QName -> QName
setNamespaceUri' XName
ns (QN XName
lp XName
px XName
_ns)      = XName -> XName -> XName -> QName
newQName XName
lp XName
px XName
ns

-- | set local part

setLocalPart'                           :: XName -> QName -> QName
setLocalPart' :: XName -> QName -> QName
setLocalPart' XName
lp (QN XName
_lp XName
px XName
ns)         = XName -> XName -> XName -> QName
newQName XName
lp XName
px XName
ns

-- | set name prefix

setNamePrefix'                          :: XName -> QName -> QName
setNamePrefix' :: XName -> QName -> QName
setNamePrefix' XName
px (QN XName
lp XName
_px XName
ns)        = XName -> XName -> XName -> QName
newQName XName
lp XName
px XName
ns

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

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

qualifiedName                   :: QName -> String
qualifiedName :: QName -> String
qualifiedName (QN XName
lp XName
px XName
_ns)
    | XName -> Bool
isNullXName XName
px            = XName -> String
unXN XName
lp
    | Bool
otherwise                 = XName -> String
unXN XName
px String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: XName -> String
unXN XName
lp)

-- | functional list version of qualifiedName used in xshow

qualifiedName'                   :: QName -> String -> String
qualifiedName' :: QName -> ShowS
qualifiedName' (QN XName
lp XName
px XName
_ns)
    | XName -> Bool
isNullXName XName
px            = (XName -> String
unXN XName
lp String -> ShowS
forall a. [a] -> [a] -> [a]
++)
    | Bool
otherwise                 = (XName -> String
unXN XName
px String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XName -> String
unXN XName
lp String -> ShowS
forall a. [a] -> [a] -> [a]
++)

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

universalName                   :: QName -> String
universalName :: QName -> String
universalName                   = (String -> ShowS) -> QName -> String
buildUniversalName (\ String
ns String
lp -> Char
'{' Char -> ShowS
forall a. a -> [a] -> [a]
: String
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'}' Char -> ShowS
forall a. a -> [a] -> [a]
: String
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 :: QName -> String
universalUri                    = (String -> ShowS) -> QName -> String
buildUniversalName String -> ShowS
forall a. [a] -> [a] -> [a]
(++)

-- |
-- 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 :: (String -> ShowS) -> QName -> String
buildUniversalName String -> ShowS
bf n :: QName
n@(QN XName
_lp XName
_px XName
ns)
    | XName -> Bool
isNullXName XName
ns            = QName -> String
localPart QName
n
    | Bool
otherwise                 = XName -> String
unXN XName
ns String -> ShowS
`bf` QName -> String
localPart QName
n

showQN                          :: QName -> String
showQN :: QName -> String
showQN QName
n
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ns                   = ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ QName -> String
qualifiedName QName
n
    | Bool
otherwise                 = ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}" String -> ShowS
forall a. [a] -> [a] -> [a]
++ QName -> String
qualifiedName QName
n
    where
    ns :: String
ns = QName -> String
namespaceUri QName
n

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

mkQName'                        :: XName -> XName -> XName -> QName
mkQName' :: XName -> XName -> XName -> QName
mkQName' XName
px XName
lp XName
ns               = XName -> XName -> XName -> QName
newQName XName
lp XName
px XName
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 :: String -> String -> QName
mkPrefixLocalPart String
px String
lp
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
px                   = String -> QName
newLpName String
lp
    | Bool
otherwise                 = String -> String -> QName
newPxName String
lp String
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 :: String -> QName
mkName String
n
    | (Char
':' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
n)
      Bool -> Bool -> Bool
&&
      Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
px)                     -- more restrictive: isWellformedQualifiedName n
                                = String -> String -> QName
newPxName String
lp String
px
    | Bool
otherwise                 = String -> QName
newLpName String
n
    where
    (String
px, (Char
_ : String
lp)) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
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 :: String -> String -> String -> QName
mkQName String
px String
lp String
ns
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ns                   = String -> String -> QName
mkPrefixLocalPart String
px String
lp
    | Bool
otherwise                 = String -> String -> String -> QName
newNsName String
lp String
px String
ns

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

-- |
-- old name for 'mkName'

mkSNsName                       :: String -> QName
mkSNsName :: String -> QName
mkSNsName                       = String -> QName
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 :: String -> String -> QName
mkNsName String
n String
ns
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ns                   = QName
qn
    | Bool
otherwise                 = XName -> QName -> QName
setNamespaceUri' XName
ns' QName
qn
    where
    qn :: QName
qn                          = String -> QName
mkName String
n
    ns' :: XName
ns'                         = String -> XName
newXName String
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 :: QName -> QName -> Bool
equivQName                      = (String -> String -> Bool) -> QName -> QName -> Bool
equalQNameBy String -> String -> Bool
equivUri

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

equivUri                        :: String -> String -> Bool
equivUri :: String -> String -> Bool
equivUri String
x String
y                    = ShowS
normalizeNsUri String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ShowS
normalizeNsUri String
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 :: (String -> String -> Bool) -> QName -> QName -> Bool
equalQNameBy String -> String -> Bool
equiv QName
q1 QName
q2        = QName -> String
localPart QName
q1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
localPart QName
q2
                                  Bool -> Bool -> Bool
&&
                                  (QName -> String
namespaceUri QName
q1 String -> String -> Bool
`equiv` QName -> String
namespaceUri QName
q2)

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

normalizeNsUri                  :: String -> String
normalizeNsUri :: ShowS
normalizeNsUri                  = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
stripSlash
    where
    stripSlash :: ShowS
stripSlash String
""               = String
""
    stripSlash String
s
        | String -> Char
forall a. [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'         = ShowS
forall a. [a] -> [a]
init String
s
        | Bool
otherwise             = String
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 :: NsEnv -> QName -> QName
setNamespace NsEnv
env n :: QName
n@(QN XName
lp XName
px XName
_ns)
                                = QName -> (XName -> QName) -> Maybe XName -> QName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe QName
n (\ XName
ns -> XName -> XName -> XName -> QName
newQName XName
lp XName
px XName
ns) (Maybe XName -> QName) -> (NsEnv -> Maybe XName) -> NsEnv -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XName -> NsEnv -> Maybe XName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup XName
px (NsEnv -> QName) -> NsEnv -> QName
forall a b. (a -> b) -> a -> b
$ NsEnv
env

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

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

isNCName                        :: String -> Bool
isNCName :: String -> Bool
isNCName []                     = Bool
False
isNCName String
n                      = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ( ((Char -> Bool) -> Char -> Bool)
-> [Char -> Bool] -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
($)
                                        (Char -> Bool
isXmlNCNameStartChar (Char -> Bool) -> [Char -> Bool] -> [Char -> Bool]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> [Char -> Bool]
forall a. a -> [a]
repeat Char -> Bool
isXmlNCNameChar)
                                        String
n
                                      )

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

isWellformedQualifiedName       :: String -> Bool
isWellformedQualifiedName :: String -> Bool
isWellformedQualifiedName String
s
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
lp                   = String -> Bool
isNCName String
px
    | Bool
otherwise                 = String -> Bool
isNCName String
px Bool -> Bool -> Bool
&& String -> Bool
isNCName (ShowS
forall a. [a] -> [a]
tail String
lp)
    where
    (String
px, String
lp)                    = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
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 :: QName -> Bool
isWellformedQName (QN XName
lp XName
px XName
_ns)
                                = (String -> Bool
isNCName (String -> Bool) -> (XName -> String) -> XName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XName -> String
unXN) XName
lp                          -- rule [8] XML Namespaces
                                  Bool -> Bool -> Bool
&&
                                  ( XName -> Bool
isNullXName XName
px
                                    Bool -> Bool -> Bool
||
                                    (String -> Bool
isNCName (String -> Bool) -> (XName -> String) -> XName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XName -> String
unXN) XName
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 :: QName -> Bool
isWellformedNSDecl QName
n
                                = Bool -> Bool
not (QName -> Bool
isNameSpaceName QName
n)
                                  Bool -> Bool -> Bool
||
                                  QName -> Bool
isWellformedNameSpaceName QName
n

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

isWellformedNameSpaceName       :: QName -> Bool
isWellformedNameSpaceName :: QName -> Bool
isWellformedNameSpaceName n :: QName
n@(QN XName
lp XName
px XName
_ns)
    | XName -> Bool
isNullXName XName
px            = XName
lp XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlnsXName
    | Bool
otherwise                 = XName
px XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlnsXName
                                  Bool -> Bool -> Bool
&&
                                  Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
lp')
                                  Bool -> Bool -> Bool
&&
                                  Bool -> Bool
not (String
a_xml String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
lp')
    where
    lp' :: String
lp'                         = QName -> String
localPart QName
n


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

isNameSpaceName                         :: QName -> Bool
isNameSpaceName :: QName -> Bool
isNameSpaceName (QN XName
lp XName
px XName
_ns)
    | XName -> Bool
isNullXName XName
px                    = XName
lp XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlnsXName
    | Bool
otherwise                         = XName
px XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlnsXName

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

isDeclaredNamespace                     :: QName -> Bool
isDeclaredNamespace :: QName -> Bool
isDeclaredNamespace (QN XName
_lp XName
px XName
ns)
    | XName -> Bool
isNullXName XName
px                    = Bool
True                          -- no namespace used
    | XName
px XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlnsXName                  = XName
ns XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlnsNamespaceXName     -- "xmlns" has a predefined namespace uri
    | XName
px XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlXName                    = XName
ns XName -> XName -> Bool
forall a. Eq a => a -> a -> Bool
== XName
xmlNamespaceXName       -- "xml" has a predefiend namespace"
    | Bool
otherwise                         = Bool -> Bool
not (XName -> Bool
isNullXName XName
ns)          -- namespace values are not empty

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

toNsEnv                         :: AssocList String String -> NsEnv
toNsEnv :: AssocList String String -> NsEnv
toNsEnv                         = ((String, String) -> (XName, XName))
-> AssocList String String -> NsEnv
forall a b. (a -> b) -> [a] -> [b]
map (String -> XName
newXName (String -> XName)
-> (String -> XName) -> (String, String) -> (XName, XName)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> XName
newXName)

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

-- the name and string cache

data NameCache          = NC { NameCache -> Int
_newXN   :: !Int                                       -- next free name id
                             , NameCache -> Map String XName
_xnCache :: !(M.Map String XName)
                             , NameCache -> Map (XName, XName, XName) QName
_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            :: IORef NameCache
theNameCache :: IORef NameCache
theNameCache            = IO (IORef NameCache) -> IORef NameCache
forall a. IO a -> a
unsafePerformIO (NameCache -> IO (IORef NameCache)
forall a. a -> IO (IORef a)
newIORef (NameCache -> IO (IORef NameCache))
-> NameCache -> IO (IORef NameCache)
forall a b. (a -> b) -> a -> b
$ NameCache
initialCache)
{-# NOINLINE theNameCache #-}

initialXNames           :: [XName]

nullXName
 , xmlnsNamespaceXName
 , xmlnsXName
 , xmlNamespaceXName
 , xmlXName             :: XName

initialXNames :: [XName]
initialXNames@[
   XName
nullXName
 , XName
xmlnsNamespaceXName
 , XName
xmlnsXName
 , XName
xmlNamespaceXName
 , XName
xmlXName
 ]                      = (Int -> String -> XName) -> [Int] -> [String] -> [XName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> String -> XName
XN [Int
0..] ([String] -> [XName]) -> [String] -> [XName]
forall a b. (a -> b) -> a -> b
$
                          [ String
""
                          , String
xmlnsNamespace
                          , String
a_xmlns
                          , String
xmlNamespace
                          , String
a_xml
                          ]

initialQNames           :: [QName]

xmlnsQN                 :: QName

initialQNames :: [QName]
initialQNames@[QName
xmlnsQN] = [XName -> XName -> XName -> QName
QN XName
xmlnsXName XName
nullXName XName
xmlnsNamespaceXName]

initialCache            :: NameCache
initialCache :: NameCache
initialCache            = Int
-> Map String XName -> Map (XName, XName, XName) QName -> NameCache
NC
                          ([XName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XName]
initialXNames)
                          ([(String, XName)] -> Map String XName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, XName)] -> Map String XName)
-> [(String, XName)] -> Map String XName
forall a b. (a -> b) -> a -> b
$ (XName -> (String, XName)) -> [XName] -> [(String, XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ XName
xn -> (XName -> String
unXN XName
xn, XName
xn)) [XName]
initialXNames)
                          ([((XName, XName, XName), QName)] -> Map (XName, XName, XName) QName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((XName, XName, XName), QName)]
 -> Map (XName, XName, XName) QName)
-> [((XName, XName, XName), QName)]
-> Map (XName, XName, XName) QName
forall a b. (a -> b) -> a -> b
$ (QName -> ((XName, XName, XName), QName))
-> [QName] -> [((XName, XName, XName), QName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ qn :: QName
qn@(QN XName
lp XName
px XName
ns) -> ((XName
lp, XName
px, XName
ns), QName
qn)) [QName]
initialQNames)

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

changeNameCache         :: NFData r => ChangeNameCache r -> r
changeNameCache :: ChangeNameCache r -> r
changeNameCache ChangeNameCache r
action  = IO r -> r
forall a. IO a -> a
unsafePerformIO IO r
changeNameCache'
    where
    action' :: ChangeNameCache r
action' NameCache
c =
      let r :: (NameCache, r)
r = ChangeNameCache r
action NameCache
c
      in
       (NameCache, r) -> NameCache
forall a b. (a, b) -> a
fst (NameCache, r)
r NameCache -> (NameCache, r) -> (NameCache, r)
`seq` (NameCache, r)
r    -- eval name cache to whnf

    changeNameCache' :: IO r
changeNameCache' =
      do
      -- putStrLn "modify cache"
      r
res <- IORef NameCache -> ChangeNameCache r -> IO r
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef NameCache
theNameCache ChangeNameCache r
action'
      -- putStrLn "cache modified"
      r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return r
res

{-# NOINLINE changeNameCache #-}

newXName'               :: String -> ChangeNameCache XName
newXName' :: String -> ChangeNameCache XName
newXName' String
n c :: NameCache
c@(NC Int
nxn Map String XName
xm Map (XName, XName, XName) QName
qm)
                        = case String -> Map String XName -> Maybe XName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
n Map String XName
xm of
                          Just XName
xn       -> (NameCache
c, XName
xn)
                          Maybe XName
Nothing       -> let nxn' :: Int
nxn' = Int
nxn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in
                                           let xn :: XName
xn   = (Int -> String -> XName
XN Int
nxn String
n) in
                                           let xm' :: Map String XName
xm'  = String -> XName -> Map String XName -> Map String XName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
n XName
xn Map String XName
xm in
                                           -- trace ("newXName: XN " ++ show nxn ++ " " ++ show n) $
                                           XName -> ()
forall a. NFData a => a -> ()
rnf XName
xn () -> (NameCache, XName) -> (NameCache, XName)
`seq` (Int
-> Map String XName -> Map (XName, XName, XName) QName -> NameCache
NC Int
nxn' Map String XName
xm' Map (XName, XName, XName) QName
qm, XName
xn)

newQName'               :: XName -> XName -> XName -> ChangeNameCache QName
newQName' :: XName -> XName -> XName -> ChangeNameCache QName
newQName' XName
lp XName
px XName
ns c :: NameCache
c@(NC Int
nxn Map String XName
xm Map (XName, XName, XName) QName
qm)
                        = case (XName, XName, XName)
-> Map (XName, XName, XName) QName -> Maybe QName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (XName, XName, XName)
q' Map (XName, XName, XName) QName
qm of
                          Just QName
qn       -> -- trace ("oldQName: " ++ show qn) $                 -- log evaluation sequence
                                           (NameCache
c, QName
qn)
                          Maybe QName
Nothing       -> let qm' :: Map (XName, XName, XName) QName
qm'  = (XName, XName, XName)
-> QName
-> Map (XName, XName, XName) QName
-> Map (XName, XName, XName) QName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (XName, XName, XName)
q' QName
q Map (XName, XName, XName) QName
qm in
                                           -- trace ("newQName: " ++ show q) $                  -- log insertion of a new QName
                                           QName
q QName -> (NameCache, QName) -> (NameCache, QName)
`seq` (Int
-> Map String XName -> Map (XName, XName, XName) QName -> NameCache
NC Int
nxn Map String XName
xm Map (XName, XName, XName) QName
qm', QName
q)
    where
    q' :: (XName, XName, XName)
q'                  = (XName
lp, XName
px, XName
ns)
    q :: QName
q                   = XName -> XName -> XName -> QName
QN XName
lp XName
px XName
ns

andThen                 :: ChangeNameCache r1 ->
                           (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
andThen :: ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
andThen ChangeNameCache r1
a1 r1 -> ChangeNameCache r2
a2 NameCache
c0        = let (NameCache
c1, r1
r1) = ChangeNameCache r1
a1 NameCache
c0 in
                          (r1 -> ChangeNameCache r2
a2 r1
r1) NameCache
c1

newXName                :: String -> XName
newXName :: String -> XName
newXName String
n              = ChangeNameCache XName -> XName
forall r. NFData r => ChangeNameCache r -> r
changeNameCache (ChangeNameCache XName -> XName) -> ChangeNameCache XName -> XName
forall a b. (a -> b) -> a -> b
$
                          String -> ChangeNameCache XName
newXName' String
n

newQName                :: XName -> XName -> XName -> QName
newQName :: XName -> XName -> XName -> QName
newQName XName
lp XName
px XName
ns       = XName
lp XName -> QName -> QName
`seq` XName
px XName -> QName -> QName
`seq` XName
ns XName -> QName -> QName
`seq`            -- XNames must be evaluated, else MVar blocks
                          ( ChangeNameCache QName -> QName
forall r. NFData r => ChangeNameCache r -> r
changeNameCache (ChangeNameCache QName -> QName) -> ChangeNameCache QName -> QName
forall a b. (a -> b) -> a -> b
$
                            XName -> XName -> XName -> ChangeNameCache QName
newQName' XName
lp XName
px XName
ns
                          )

newLpName               :: String -> QName
newLpName :: String -> QName
newLpName String
lp            = ChangeNameCache QName -> QName
forall r. NFData r => ChangeNameCache r -> r
changeNameCache (ChangeNameCache QName -> QName) -> ChangeNameCache QName -> QName
forall a b. (a -> b) -> a -> b
$
                          String -> ChangeNameCache XName
newXName' String
lp ChangeNameCache XName
-> (XName -> ChangeNameCache QName) -> ChangeNameCache QName
forall r1 r2.
ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
`andThen` \ XName
lp' ->
                          XName -> XName -> XName -> ChangeNameCache QName
newQName' XName
lp' XName
nullXName XName
nullXName

newPxName               :: String -> String -> QName
newPxName :: String -> String -> QName
newPxName String
lp String
px         = ChangeNameCache QName -> QName
forall r. NFData r => ChangeNameCache r -> r
changeNameCache (ChangeNameCache QName -> QName) -> ChangeNameCache QName -> QName
forall a b. (a -> b) -> a -> b
$
                          String -> ChangeNameCache XName
newXName' String
lp ChangeNameCache XName
-> (XName -> ChangeNameCache QName) -> ChangeNameCache QName
forall r1 r2.
ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
`andThen` \ XName
lp' ->
                          String -> ChangeNameCache XName
newXName' String
px ChangeNameCache XName
-> (XName -> ChangeNameCache QName) -> ChangeNameCache QName
forall r1 r2.
ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
`andThen` \ XName
px' ->
                          XName -> XName -> XName -> ChangeNameCache QName
newQName' XName
lp' XName
px' XName
nullXName

newNsName               :: String -> String -> String -> QName
newNsName :: String -> String -> String -> QName
newNsName String
lp String
px String
ns      = ChangeNameCache QName -> QName
forall r. NFData r => ChangeNameCache r -> r
changeNameCache (ChangeNameCache QName -> QName) -> ChangeNameCache QName -> QName
forall a b. (a -> b) -> a -> b
$
                          String -> ChangeNameCache XName
newXName' String
lp ChangeNameCache XName
-> (XName -> ChangeNameCache QName) -> ChangeNameCache QName
forall r1 r2.
ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
`andThen` \ XName
lp' ->
                          String -> ChangeNameCache XName
newXName' String
px ChangeNameCache XName
-> (XName -> ChangeNameCache QName) -> ChangeNameCache QName
forall r1 r2.
ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
`andThen` \ XName
px' ->
                          String -> ChangeNameCache XName
newXName' String
ns ChangeNameCache XName
-> (XName -> ChangeNameCache QName) -> ChangeNameCache QName
forall r1 r2.
ChangeNameCache r1
-> (r1 -> ChangeNameCache r2) -> ChangeNameCache r2
`andThen` \ XName
ns' ->
                          XName -> XName -> XName -> ChangeNameCache QName
newQName' XName
lp' XName
px' XName
ns'

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