-- |
-- 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