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

{- |
   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 :: XmlTree -> XmlArrow
validateIds XmlTree
dtdPart
    = XmlTrees -> XmlArrow
validateIds' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idEnv)
      where
      idAttrTypes :: XmlTrees
idAttrTypes = forall a b. LA a b -> a -> [b]
runLA (forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType) XmlTree
dtdPart
      elements :: XmlTrees
elements    = forall a b. LA a b -> a -> [b]
runLA (forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement) XmlTree
dtdPart
      atts :: XmlTrees
atts        = forall a b. LA a b -> a -> [b]
runLA (forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist) XmlTree
dtdPart
      idEnv :: IdEnvTable
idEnv       = XmlTrees -> IdEnvTable
buildIdCollectorFcts XmlTrees
idAttrTypes

      validateIds'      :: XmlTrees -> XmlArrow
      validateIds' :: XmlTrees -> XmlArrow
validateIds' XmlTrees
idNodeList
          = ( forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA XmlTrees
idNodeList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> XmlTrees -> LA XmlTrees XmlTree
checkForUniqueIds XmlTrees
idAttrTypes )
            forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
            IdEnvTable -> XmlArrow
checkIdReferences IdEnvTable
idRefEnv
          where
          idRefEnv :: IdEnvTable
idRefEnv   = XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable
buildIdrefValidationFcts XmlTrees
idAttrTypes XmlTrees
elements XmlTrees
atts XmlTrees
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 :: IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idEnv
    = forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (String -> XmlArrow
idFct forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName))
      where
      idFct             :: String -> XmlArrow
      idFct :: String -> XmlArrow
idFct String
name        = forall a. a -> Maybe a -> a
fromMaybe forall (a :: * -> * -> *) b c. ArrowList a => a b c
none forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name forall a b. (a -> b) -> a -> b
$ IdEnvTable
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 :: XmlTrees -> XmlTree -> String
getIdValue XmlTrees
dns
    = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. LA a b -> a -> [b]
runLA (forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b c
single LA XmlTree String
getIdValue')
    where
    getIdValue' :: LA XmlTree String
    getIdValue' :: LA XmlTree String
getIdValue'
        = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA (forall a b. (a -> b) -> [a] -> [b]
map forall {a :: * -> * -> *}.
ArrowXml a =>
XmlTree -> a XmlTree String
getIdVal XmlTrees
dns)
        where
        getIdVal :: XmlTree -> a XmlTree String
getIdVal XmlTree
dn
            | XmlTree -> Bool
isDTDAttlistNode XmlTree
dn       = forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
elemName
                                          forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                                          ( forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue0 String
attrName
                                            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                                            forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
dn))
                                          )
            | Bool
otherwise                 = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
            where
            al :: Attributes
al       = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
            elemName :: String
elemName = Attributes -> String
dtd_name  Attributes
al
            attrName :: String
attrName = Attributes -> String
dtd_value Attributes
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 :: XmlTrees -> IdEnvTable
buildIdCollectorFcts XmlTrees
idAttrTypes
    = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlTree -> IdEnvTable
buildIdCollectorFct XmlTrees
idAttrTypes
      where
      buildIdCollectorFct :: XmlTree -> [IdEnv]
      buildIdCollectorFct :: XmlTree -> IdEnvTable
buildIdCollectorFct XmlTree
dn
          | XmlTree -> Bool
isDTDAttlistNode XmlTree
dn = [(String
elemName, forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attrName)]
          | Bool
otherwise           = []
          where
          al :: Attributes
al       = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
          elemName :: String
elemName = Attributes -> String
dtd_name  Attributes
al
          attrName :: String
attrName = Attributes -> String
dtd_value Attributes
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 :: XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable
buildIdrefValidationFcts XmlTrees
idAttrTypes XmlTrees
elements XmlTrees
atts XmlTrees
idNodeList
    = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlTree -> IdEnvTable
buildElemValidationFct XmlTrees
elements
      where
      idValueList :: [String]
idValueList = forall a b. (a -> b) -> [a] -> [b]
map (XmlTrees -> XmlTree -> String
getIdValue XmlTrees
idAttrTypes) XmlTrees
idNodeList

      buildElemValidationFct :: XmlTree -> [IdEnv]
      buildElemValidationFct :: XmlTree -> IdEnvTable
buildElemValidationFct XmlTree
dn
          | XmlTree -> Bool
isDTDElementNode XmlTree
dn = [(String
elemName, XmlTrees -> XmlArrow
buildIdrefValidationFct XmlTrees
idRefAttrTypes)]
          | Bool
otherwise           = []
          where
          al :: Attributes
al             = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
          elemName :: String
elemName       = Attributes -> String
dtd_name Attributes
al
          idRefAttrTypes :: XmlTrees
idRefAttrTypes = (forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdRefAttrType) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
atts

      buildIdrefValidationFct :: XmlTrees -> XmlArrow
      buildIdrefValidationFct :: XmlTrees -> XmlArrow
buildIdrefValidationFct
          = forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
buildIdref

      buildIdref        :: XmlTree -> XmlArrow
      buildIdref :: XmlTree -> XmlArrow
buildIdref XmlTree
dn
          | XmlTree -> Bool
isDTDAttlistNode XmlTree
dn = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (String -> XmlArrow
checkIdref forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
          | Bool
otherwise           = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          where
          al :: Attributes
al             = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
          attrName :: String
attrName = Attributes -> String
dtd_value Attributes
al
          attrType :: String
attrType = Attributes -> String
dtd_type  Attributes
al

          checkIdref :: String -> XmlArrow
          checkIdref :: String -> XmlArrow
checkIdref String
name
              = forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attrName
                forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                ( String -> XmlArrow
checkIdVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
attrName )
              where
              checkIdVal        :: String -> XmlArrow
              checkIdVal :: String -> XmlArrow
checkIdVal String
av
                  | String
attrType forall a. Eq a => a -> a -> Bool
== String
k_idref
                      = String -> XmlArrow
checkValueDeclared String
attrValue
                  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
valueList
                      = forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrName forall a. [a] -> [a] -> [a]
++
                              String
" of Element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++
                              String
" must have at least one name."
                            )
                  | Bool
otherwise
                      = forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> XmlArrow
checkValueDeclared forall a b. (a -> b) -> a -> b
$ [String]
valueList
                  where
                  valueList :: [String]
valueList = String -> [String]
words String
attrValue
                  attrValue :: String
attrValue = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
dn) String
av

          checkValueDeclared :: String -> XmlArrow
          checkValueDeclared :: String -> XmlArrow
checkValueDeclared  String
attrValue
              = if String
attrValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
idValueList
                then forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                else forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"An Element with identifier " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++
                           String
" 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 :: XmlTrees -> LA XmlTrees XmlTree
checkForUniqueIds XmlTrees
idAttrTypes            -- idNodeList
    = forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
                   forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                   forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
                   forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                   (String -> XmlTree -> SLA [String] XmlTree XmlTree
checkForUniqueId forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: * -> * -> *) b. ArrowList a => a b b
this)
                 )
      where
      checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree
      checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree
checkForUniqueId String
name XmlTree
x
          = forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState
                  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                  forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (String
attrValue forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
                )
            (forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attrValue forall a. [a] -> [a] -> [a]
++ String
" of type ID for element " forall a. [a] -> [a] -> [a]
++
                   forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
" must be unique within the document." ))
            (forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState (String
attrValueforall a. a -> [a] -> [a]
:) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. ArrowList a => a b c
none)
          where
          attrValue :: String
attrValue = XmlTrees -> XmlTree -> String
getIdValue (forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
name XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
idAttrTypes) XmlTree
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 :: IdEnvTable -> XmlArrow
checkIdReferences IdEnvTable
idRefEnv
    = IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idRefEnv

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