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

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

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