content: -- |
  -- Namespace filter
  --
  -- Namespaces are processed with two main filter, 'propagateNamespaces'
  -- and 'validateNamespaces'.
  --
  -- 'propagateNamespaces' takes a XML tree and
  -- attaches extra namespace info at every tag name and attribute name.
  -- So after processing a tree with 'propagateNamespaces', the access functions
  -- "namespaceOf" and "universalNameOf" deliver the associated namespace (or \"\")
  -- for tag names and attribute names.
  --
  -- 'validateNamespaces' checks whether names are wellformed related to the XML namespace definition.
  -- whether a legal namespace is declared for all prefixes, and whether attribute names are unique
  -- related to universal names.
  
  module Text.XML.HXT.DOM.NamespaceFilter
      ( module Text.XML.HXT.DOM.NamespaceFilter
      )
  where
  
  import Text.XML.HXT.DOM.XmlTree
  
  import Text.XML.HXT.DOM.Util
      ( doubles )
  
  -- -----------------------------------------------------------------------------
  --
  
  -- |
  -- Type for the namespace association list, used when propagating namespaces by
  -- modifying the 'QName' values in a tree
  
  type NamespaceTable = NsEnv
  
  -- -----------------------------------------------------------------------------
  
  -- |
  -- propagate all namespace declarations \"xmlns:ns=...\" to all
  -- tag and attribute nodes of a document.
  --
  -- This filter does not check for illegal use of namespaces.
  -- The real work is done by 'propagateNamespaceEnv'.
  --
  -- The filter may be applied repeatedly if neccessary.
  
  propagateNamespaces     :: XmlFilter
  propagateNamespaces     = propagateNamespaceEnv $ toNsEnv [ (a_xml, xmlNamespace), (a_xmlns, xmlnsNamespace) ]
  
  -- |
  -- attaches the namespace info given by the namespace table
  -- to a tag node and its attributes and children.
  
  propagateNamespaceEnv   :: NamespaceTable -> XmlFilter
  propagateNamespaceEnv env n
      = ( ( processAttr (attachNamespaceUrisToAttr newEnv)
            .>
            processChildren (propagateNamespaceEnv newEnv)
            .>
            modifyQName (setNamespace newEnv)
          )
          `when`
          isXTag
        )
        $ n
      where
      nsAttrs     = getAttrl                              -- scan all attributes
                    .>
                    isOfAttr ( (\ (px, lp)
                               -> (px == a_xmlns          -- check for prefix or whole name is "xmlns"
                                   &&
                                   lp /= ":"              -- check for none empty local part, "xmlns:" is not a legal name
                                  )
                               )
                               . span (/= ':')            -- break the name into a pair ("prefix", ":localPart")
                               . qualifiedName            -- select attribute name
                             )
                    $ n
      nsDecl      = zip (map (drop 1                      -- drop the ":", empty local part represents default name space
                              . snd                       -- take the local part with leading ":"
                              . span (/= ':')             -- break it like above
                              . nameOf                    -- select attribute name
                             ) nsAttrs)
                        (map (xshow
                              .
                              getChildren
                             ) nsAttrs)
      newEnv      = addEntries (toNsEnv nsDecl) env
  
      attachNamespaceUrisToAttr   :: NamespaceTable -> XmlFilter
      attachNamespaceUrisToAttr attrEnv
          = ( isOfAttr ( (\ (px, lp)
                          -> ( (not . null . drop 1) lp   -- prefix and local part must not be empty
                               &&
                               (not . null) px
                             )
                         )
                         . span (/= ':')                  -- break the name into a pair ("prefix", ":localPart")
                         . qualifiedName                  -- select attribute name
                       )
              `guards`
              modifyQName (setNamespace attrEnv)
            )
            `orElse`
            ( modifyQName (const xmlnsQN)                 -- "xmlns" ist the only attr name without prefix but with an associated namespace URI
              `when`
              isAttr a_xmlns
            )
  
  -- -----------------------------------------------------------------------------
  
  -- |
  -- validate the namespace constraints in a whole tree.
  -- result is the list of errors concerning namespaces.
  -- Work is done by applying 'validate1Namespaces' to all nodes.
  -- Predicates 'isWellformedQName', 'isWellformedQualifiedName', 'isDeclaredNamespace'
  -- and 'isWellformedNSDecl' are applied to the appropriate tags and attributes.
  
  validateNamespaces      :: XmlFilter
  validateNamespaces
      = choice [ isRoot
                 :-> getChildren .> validateNamespaces            -- root is correct by definition
               , this
                 :-> multi validate1Namespaces
               ]
  
  -- |
  -- a single node for namespace constrains.
  
  validate1Namespaces     :: XmlFilter
  validate1Namespaces
      = choice [ isXTag
                 :->
                 cat [ isOfTag ( not . isWellformedQName )
                       `guards`
                       (\ n -> err ("tag name " ++ show (nameOf n) ++ " is not a wellformed qualified name") n )
  
                     , isOfTag ( not . isDeclaredNamespace )
                       `guards`
                       (\ n -> err ("namespace for prefix in tag name " ++ show (nameOf n) ++ " is undefined") n )
  
                     , (\ n -> ( let
                                 dbls = doubles ((map universalNameOf . getAttrl) n)
                                 in
                                 if null dbls
                                 then none
                                 else err ( "multiple occurences of universal names for attributes of tag "
                                            ++ show (nameOf n)
                                            ++ " : " ++ foldr1 (\ x y -> x ++ ", " ++ y) (map show dbls)
                                          )
                               ) $ n
                       )
  
                     , getAttrl .> validate1Namespaces
                     ]
  
               , isXAttr
                 :->
                 cat [ isOfAttr ( not . isWellformedQName )
                       `guards`
                       (\ n -> err ("attribute name " ++ show (nameOf n) ++ " is not a wellformed qualified name") n )
  
                     , isOfAttr ( not . isDeclaredNamespace )
                       `guards`
                       (\ n -> err ("namespace for prefix in attribute name " ++ show (nameOf n) ++ " is undefined") n )
  
                     , ( hasPrefix a_xmlns .> neg (xmlTreesToText . getChildren) )
                       `guards`
                       (\ n -> err ("namespace value of namespace declaration for " ++ show (nameOf n) ++ " has no value") n )
  
                     , isOfAttr ( not . isWellformedNSDecl )
                       `guards`
                       (\ n -> err ("illegal namespace declaration with reserved prefix " ++ show (localPartOf n) ++ " starting with \"xml\"") n )
                     ]
  
               , isXDTD
                 :->
                 cat [ ( ( isDoctype +++ isAttlist +++ isElement +++ isDTDName )
                         .>
                         isOf ( not . isWellformedQualifiedName . valueOfDTD a_name )
                       )
                       `guards`
                       (\ n -> err ("a DTD part contains a not wellformed qualified Name: " ++ show (valueOfDTD a_name n)) n )
  
                     , ( isAttlist
                         .>
                         isOf ( not . isWellformedQualifiedName . valueOfDTD a_value )
                       )
                       `guards`
                       (\ n -> err ("an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " ++ show (valueOfDTD a_value n)) n )
  
                     , ( ( isEntity +++ isParameterEntity +++ isNotation )
                         .>
                         isOf ( not . isNCName . valueOfDTD a_name )
                       )
                       `guards`
                       (\ n -> err ("an entity or notation declaration contains a not wellformed NCName: " ++ show (valueOfDTD a_name n)) n )
                     ]
               , isXPi
                 :->
                 ( isOf ( not . isNCName . nameOf )
                   `guards`
                   (\ n -> err ("a PI contains a not wellformed NCName: " ++ show (nameOf n)) n )
                 )
               ]
  
  -- -----------------------------------------------------------------------------
  
  isNamespaceDecl :: XmlFilter
  isNamespaceDecl
      = isOfAttr xmlnsName
        where
        xmlnsName :: AttrName -> Bool
        xmlnsName a
            = px == a_xmlns
              &&
              ( null ln || head ln == ':')
            where
            (px, ln) = splitAt 5 . qualifiedName $ a
  
  -- -----------------------------------------------------------------------------
  