content: -- |
  -- This module provides functions for checking special ID/IDREF/IDREFS constraints.
  
  -- Checking special ID/IDREF/IDREFS constraints means:
  --
  --  - checking that all ID values are unique.
  --
  --  - checking that all IDREF/IDREFS values match the value of some ID attribute
  --
  
  
  -- ID-Validation should be started before or after validating the document.
  
  
  -- First all nodes with ID attributes are collected from the document, then
  -- it is validated that values of ID attributes do not occure more than once.
  -- During a second iteration over the document it is validated that there exists
  -- an ID attribute value for IDREF/IDREFS attribute values.
  
  -- Special namings in source code:
  --
  --  - nd - XDTD node
  --
  --  - n  - XTag node
  --
  -- Author : .\\artin Schmidt
  
  module Text.XML.HXT.Validator.IdValidation
      ( validateIds
      )
  where
  
  
  import Text.XML.HXT.DOM.XmlTree
  import Text.XML.HXT.Validator.AttributeValueValidation
  
  
  
  -- |
  -- Lookup-table which maps element names to their validation functions. The
  -- validation functions are XmlFilters.
  
  type IdEnvTable         = [IdEnv]
  type IdEnv              = (ElemName, IdFct)
  type ElemName           = String
  type IdFct              = XmlFilter
  
  
  
  -- |
  -- Perform the validation of the ID/IDREF/IDREFS constraints.
  --
  --    * 1.parameter dtdPart :  the DTD subset (Node @DOCTYPE@) of the XmlTree
  --
  --    - 2.parameter doc :  the document subset of the XmlTree
  --
  --    - returns : a list of errors
  
  validateIds :: XmlTree -> XmlTree -> XmlTrees
  validateIds dtdPart doc
      = {-# SCC "checkForUniqueIds" #-} checkForUniqueIds idNodeList dtdNodes
        ++
        {-# SCC "checkIdReferences" #-} checkIdReferences idRefEnv doc
        where
        idEnv      = buildIdCollectorFcts dtdNodes
        idRefEnv   = buildIdrefValidationFcts dtdNodes idNodeList
        idNodeList = traverseTree idEnv doc
        dtdNodes   = getChildren dtdPart
  
  
  -- |
  -- Traverse the XmlTree in preorder.
  --
  --    * 1.parameter idEnv :  lookup-table which maps element names to their validation functions
  --
  --    - returns : list of errors
  
  traverseTree :: IdEnvTable -> XmlFilter
  traverseTree idEnv n@(NTree (XTag name _) cs)
      = (idFct n) ++ concatMap (traverseTree idEnv) cs
        where
        idFct :: XmlFilter
        idFct
            = case (lookup (qualifiedName name) idEnv) of
              Nothing -> none
              Just f  -> f
  
  traverseTree _ _ = []
  
  
  
  -- |
  -- Returns the value of an element's ID attribute. The attribute name has to be
  -- retrieved first from the DTD.
  --
  --    * 1.parameter dtdPart :  list of ID attribute definitions from the DTD
  --
  --    - 2.parameter n :  element which ID attribute value should be returned
  --
  --    - returns : normalized value of the ID attribute
  
  getIdValue :: XmlTrees -> XmlTree -> String
  getIdValue (x@(NTree (XDTD ATTLIST al) _):xs) n@(NTree (XTag name _al') _)
      = if (qualifiedName name) == elemName
        then attrValue
        else getIdValue xs n
        where
        elemName  = lookup1 a_name al
        attrName  = lookup1 a_value al
        attrValue = normalizeAttributeValue (Just x) (valueOf attrName n)
  
  getIdValue _ _ = ""
  
  
  
  -- ------------------------------------------------------------
  
  
  -- |
  -- Build collector functions which return XTag nodes with ID attributes from
  -- a document.
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - returns : lookup-table which maps element names to their collector function
  
  buildIdCollectorFcts :: XmlTrees -> IdEnvTable
  buildIdCollectorFcts dtdPart
      = map (buildIdCollectorFct) (isIdAttrType $$ dtdPart)
        where
        buildIdCollectorFct :: XmlTree -> IdEnv
        buildIdCollectorFct (NTree (XDTD ATTLIST al) _)
            = (elemName, hasAttr attrName)
              where
              elemName = lookup1 a_name al
              attrName = lookup1 a_value al
  
        buildIdCollectorFct nd
            = error ("buildIdCollectorFct: illegeal parameter:\n" ++ show nd)
  
  
  -- |
  -- Build validation functions for checking if IDREF\/IDREFS values match a value
  -- of some ID attributes.
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter idNodeList :  list of all XTag nodes with ID attributes
  --
  --    - returns : lookup-table which maps element names to their validation function
  
  buildIdrefValidationFcts :: XmlTrees -> XmlTrees -> IdEnvTable
  buildIdrefValidationFcts dtdPart idNodeList
      = map buildElemValidationFct elements
        where
        elements    = isElement $$ dtdPart
        idValueList = getIdValues (isIdAttrType $$ dtdPart)
  
        getIdValues :: XmlTrees -> [String]
        getIdValues idAttrTypes
            = map (getIdValue idAttrTypes) idNodeList
  
  
        buildElemValidationFct :: XmlTree -> IdEnv
        buildElemValidationFct (NTree (XDTD ELEMENT al) _)
            = (elemName, buildIdrefValidationFct idRefAttrTypes)
            where
            elemName = lookup1 a_name al
            idRefAttrTypes = isIdRefAttrType $$ (isAttlistOfElement elemName) $$ dtdPart
  
        buildElemValidationFct nd
            = error ("buildIdrefValidationFct: illegeal parameter:\n" ++ show nd)
  
  
        buildIdrefValidationFct :: XmlTrees -> XmlFilter
        buildIdrefValidationFct (nd@(NTree (XDTD ATTLIST al) _):xs)
            = checkIdref +++ buildIdrefValidationFct xs
              where
              attrName = lookup1 a_value al
              attrType = lookup1 a_type al
  
              checkIdref :: XmlFilter
              checkIdref n@(NTree (XTag name _) _)
                  = if satisfies (hasAttr attrName) n
                    then if attrType == k_idref
                         then checkValueDeclared n attrValue
                         else let valueList = words attrValue
                              in if null valueList
                                 then err ("Attribute " ++ show attrName ++
                                           " of Element " ++ show (qualifiedName name) ++
                                           " must have at least one name.") n
                                 else concatMap (checkValueDeclared n) (words attrValue)
                    else []
                    where
                    attrValue = normalizeAttributeValue (Just nd) (valueOf attrName n)
  
              checkIdref _ = []
  
  
              checkValueDeclared :: XmlTree -> String -> XmlTrees
              checkValueDeclared n@(NTree (XTag _ _) _) attrValue
                  = if attrValue `elem` idValueList
                    then []
                    else err ("An Element with identifier " ++ show attrValue ++
                              " must appear in the document.") n
  
              checkValueDeclared _ _ = []
  
        buildIdrefValidationFct []
            = none
  
        buildIdrefValidationFct nd
            = error ("buildIdCollectorFct: illegeal parameter:\n" ++ show nd)
  
  
  -- ------------------------------------------------------------
  
  
  -- |
  -- Validate that all ID values are unique within a document.
  -- Validity constraint: ID (3.3.1 \/p. 25 in Spec)
  --
  --    * 1.parameter idNodeList :  list of all XTag nodes with ID attributes
  --
  --    - 2.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - returns : a list of errors
  
  checkForUniqueIds :: XmlTrees -> XmlTrees -> XmlTrees
  checkForUniqueIds idNodeList dtdPart
      = checkForUniqueId idNodeList []
        where
        idAttrTypes = isIdAttrType $$ dtdPart
  
        checkForUniqueId :: XmlTrees -> [String] -> XmlTrees
        checkForUniqueId (x@(NTree (XTag name _) _):xs) used
            = if attrValue `elem` used
              then err ("Attribute value " ++ show attrValue ++ " of type ID for element " ++
                        show (qualifiedName name) ++ " must be unique within the document.") x
                   ++
                   checkForUniqueId xs used
  
              else checkForUniqueId xs (attrValue : used)
              where
              attrValue = getIdValue (isAttlistOfElement (qualifiedName name) $$ idAttrTypes) x
  
        checkForUniqueId _ _ = []
  
  
  
  -- |
  -- Validate that all IDREF\/IDREFS values match the value of some ID attribute.
  -- Validity constraint: IDREF (3.3.1 \/ p.26 in Spec)
  --
  --    * 1.parameter idRefEnv :  lookup-table which maps element names to their validation function
  --
  --    - 2.parameter doc :  the document to validate
  --
  --    - returns : a list of errors
  
  checkIdReferences :: IdEnvTable -> XmlTree -> XmlTrees
  checkIdReferences idRefEnv doc
      = traverseTree idRefEnv doc
  
  
  
  
  
  