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

{- |
   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' (XmlTrees -> XmlArrow) -> LA XmlTree XmlTrees -> XmlArrow
forall c b d. (c -> LA b d) -> LA b c -> LA b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< XmlArrow -> LA XmlTree XmlTrees
forall b c. LA b c -> LA b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (IdEnvTable -> XmlArrow
traverseTree IdEnvTable
idEnv)
      where
      idAttrTypes :: XmlTrees
idAttrTypes = XmlArrow -> XmlTree -> XmlTrees
forall a b. LA a b -> a -> [b]
runLA (XmlArrow
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType) XmlTree
dtdPart
      elements :: XmlTrees
elements    = XmlArrow -> XmlTree -> XmlTrees
forall a b. LA a b -> a -> [b]
runLA (XmlArrow
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement) XmlTree
dtdPart
      atts :: XmlTrees
atts        = XmlArrow -> XmlTree -> XmlTrees
forall a b. LA a b -> a -> [b]
runLA (XmlArrow
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> XmlArrow
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
          = ( XmlTrees -> LA XmlTree XmlTrees
forall c b. c -> LA b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA XmlTrees
idNodeList LA XmlTree XmlTrees -> LA XmlTrees XmlTree -> XmlArrow
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 )
            XmlArrow -> XmlArrow -> XmlArrow
forall b c. LA b c -> LA b c -> LA b c
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
    = XmlArrow -> XmlArrow
forall (t :: * -> *) b c. Tree t => LA (t b) c -> LA (t b) c
forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
multi (XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem XmlArrow -> XmlArrow -> XmlArrow
forall b c d. LA b c -> LA b d -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (String -> XmlArrow
idFct (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
forall c b d. (c -> LA b d) -> LA b c -> LA b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName))
      where
      idFct             :: String -> XmlArrow
      idFct :: String -> XmlArrow
idFct String
name        = XmlArrow -> Maybe XmlArrow -> XmlArrow
forall a. a -> Maybe a -> a
fromMaybe XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none (Maybe XmlArrow -> XmlArrow)
-> (IdEnvTable -> Maybe XmlArrow) -> IdEnvTable -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IdEnvTable -> Maybe XmlArrow
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name (IdEnvTable -> XmlArrow) -> IdEnvTable -> XmlArrow
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
    = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (XmlTree -> [String]) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree String -> XmlTree -> [String]
forall a b. LA a b -> a -> [b]
runLA (LA XmlTree String -> LA XmlTree String
forall b c. LA b c -> LA b c
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'
        = XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem XmlArrow -> LA XmlTree String -> LA XmlTree String
forall b c d. LA b c -> LA b d -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` [LA XmlTree String] -> LA XmlTree String
forall b c. [LA b c] -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ((XmlTree -> LA XmlTree String) -> XmlTrees -> [LA XmlTree String]
forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> LA XmlTree String
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       = String -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
elemName
                                          a XmlTree XmlTree -> a XmlTree String -> a XmlTree String
forall b c d. a b c -> a b d -> a b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                                          ( String -> a XmlTree String
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue0 String
attrName
                                            a XmlTree String -> a String String -> a XmlTree String
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                                            (String -> String) -> a String String
forall b c. (b -> c) -> a b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Maybe XmlTree -> String -> String
normalizeAttributeValue (XmlTree -> Maybe XmlTree
forall a. a -> Maybe a
Just XmlTree
dn))
                                          )
            | Bool
otherwise                 = a XmlTree String
forall b c. a b c
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
    = (XmlTree -> IdEnvTable) -> XmlTrees -> IdEnvTable
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, String -> XmlArrow
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
    = (XmlTree -> IdEnvTable) -> XmlTrees -> IdEnvTable
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XmlTree -> IdEnvTable
buildElemValidationFct XmlTrees
elements
      where
      idValueList :: [String]
idValueList = (XmlTree -> String) -> XmlTrees -> [String]
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 = (String -> XmlArrow
forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName XmlArrow -> XmlArrow -> XmlArrow
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdRefAttrType) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
atts

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

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

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