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

    {- |
       Module     : Text.XML.HXT.DTDValidation.IdValidation
       Copyright  : Copyright (C) 2008 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable

       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.

    -}

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

    module Text.XML.HXT.DTDValidation.IdValidation
        ( validateIds
        )
    where

    import Data.Maybe

    import Text.XML.HXT.DTDValidation.TypeDefs
    import Text.XML.HXT.DTDValidation.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              = XmlArrow

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

    -- |
    -- 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 -> XmlArrow
    validateIds dtdPart
        = validateIds' $< listA (traverseTree idEnv)
          where
          idAttrTypes = runLA (getChildren >>> isIdAttrType) dtdPart
          elements    = runLA (getChildren >>> isDTDElement) dtdPart
          atts        = runLA (getChildren >>> isDTDAttlist) dtdPart
          idEnv       = buildIdCollectorFcts idAttrTypes

          validateIds'      :: XmlTrees -> XmlArrow
          validateIds' idNodeList
              = ( constA idNodeList >>> checkForUniqueIds idAttrTypes )
                <+>
                checkIdReferences idRefEnv
              where
              idRefEnv   = buildIdrefValidationFcts idAttrTypes elements atts idNodeList

    -- |
    -- Traverse the XmlTree in preorder.
    --
    --    * 1.parameter idEnv :  lookup-table which maps element names to their validation functions
    --
    --    - returns : list of errors

    traverseTree :: IdEnvTable -> XmlArrow
    traverseTree idEnv
        = multi (isElem `guards` (idFct $< getName))
          where
          idFct             :: String -> XmlArrow
          idFct name        = fromMaybe none . lookup name $ idEnv

    -- |
    -- 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 dns
        = concat . runLA (single getIdValue')
        where
        getIdValue' :: LA XmlTree String
        getIdValue'
            = isElem `guards` catA (map getIdVal dns)
            where
            getIdVal dn
                | isDTDAttlistNode dn       = hasName elemName
                                              `guards`
                                              ( getAttrValue0 attrName
                                                >>>
                                                arr (normalizeAttributeValue (Just dn))
                                              )
                | otherwise                 = none
                where
                al       = getDTDAttributes dn
                elemName = dtd_name  al
                attrName = dtd_value al

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

    -- |
    -- 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 idAttrTypes
        = concatMap buildIdCollectorFct idAttrTypes
          where
          buildIdCollectorFct :: XmlTree -> [IdEnv]
          buildIdCollectorFct dn
              | isDTDAttlistNode dn = [(elemName, hasAttr attrName)]
              | otherwise           = []
              where
              al       = getDTDAttributes dn
              elemName = dtd_name  al
              attrName = dtd_value al

    -- |
    -- 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 -> XmlTrees -> XmlTrees -> IdEnvTable
    buildIdrefValidationFcts idAttrTypes elements atts idNodeList
        = concatMap buildElemValidationFct elements
          where
          idValueList = map (getIdValue idAttrTypes) idNodeList

          buildElemValidationFct :: XmlTree -> [IdEnv]
          buildElemValidationFct dn
              | isDTDElementNode dn = [(elemName, buildIdrefValidationFct idRefAttrTypes)]
              | otherwise           = []
              where
              al             = getDTDAttributes dn
              elemName       = dtd_name al
              idRefAttrTypes = (isAttlistOfElement elemName >>> isIdRefAttrType) $$ atts

          buildIdrefValidationFct :: XmlTrees -> XmlArrow
          buildIdrefValidationFct
              = catA . map buildIdref

          buildIdref        :: XmlTree -> XmlArrow
          buildIdref dn
              | isDTDAttlistNode dn = isElem >>> (checkIdref $< getName)
              | otherwise           = none
              where
              al             = getDTDAttributes dn
              attrName = dtd_value al
              attrType = dtd_type  al

              checkIdref :: String -> XmlArrow
              checkIdref name
                  = hasAttr attrName
                    `guards`
                    ( checkIdVal $< getAttrValue attrName )
                  where
                  checkIdVal        :: String -> XmlArrow
                  checkIdVal av
                      | attrType == k_idref
                          = checkValueDeclared attrValue
                      | null valueList
                          = err ( "Attribute " ++ show attrName ++
                                  " of Element " ++ show name ++
                                  " must have at least one name."
                                )
                      | otherwise
                          = catA . map checkValueDeclared $ valueList
                      where
                      valueList = words attrValue
                      attrValue = normalizeAttributeValue (Just dn) av

              checkValueDeclared :: String -> XmlArrow
              checkValueDeclared  attrValue
                  = if attrValue `elem` idValueList
                    then none
                    else err ( "An Element with identifier " ++ show attrValue ++
                               " must appear in the document."
                             )

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

    -- |
    -- 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 -> LA XmlTrees XmlTree
    checkForUniqueIds idAttrTypes            -- idNodeList
        = fromSLA [] ( unlistA
                       >>>
                       isElem
                       >>>
                       (checkForUniqueId $<< getName &&& this)
                     )
          where
          checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree
          checkForUniqueId name x
              = ifA ( getState
                      >>>
                      isA (attrValue `elem`)
                    )
                (err ( "Attribute value " ++ show attrValue ++ " of type ID for element " ++
                       show name ++ " must be unique within the document." ))
                (nextState (attrValue:) >>> none)
              where
              attrValue = getIdValue (isAttlistOfElement name $$ idAttrTypes) x

    -- |
    -- 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 -> LA XmlTree XmlTree
    checkIdReferences idRefEnv
        = traverseTree idRefEnv

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