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

    {- |
       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 dtdPart :: XmlTree
    dtdPart
        = XmlTrees -> XmlArrow
    validateIds' (XmlTrees -> XmlArrow) -> LA XmlTree XmlTrees -> XmlArrow
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< XmlArrow -> LA XmlTree XmlTrees
    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 (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 (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 (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' idNodeList :: XmlTrees
    idNodeList
              = ( XmlTrees -> LA XmlTree XmlTrees
    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 (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 idEnv :: IdEnvTable
    idEnv
        = XmlArrow -> XmlArrow
    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 (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 (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 name :: String
    name        = XmlArrow -> Maybe XmlArrow -> XmlArrow
    forall a. a -> Maybe a -> a
    fromMaybe XmlArrow
    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 dns :: 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 (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 (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d
    `guards` [LA XmlTree String] -> LA XmlTree String
    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 dn :: 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 (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 (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 (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 idAttrTypes :: 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 dn :: 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 idAttrTypes :: XmlTrees
    idAttrTypes elements :: XmlTrees
    elements atts :: XmlTrees
    atts idNodeList :: 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 dn :: 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 (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 dn :: 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 (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 (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 name :: String
    name
                  = String -> XmlArrow
    forall (a :: * -> * -> *).
    ArrowXml a =>
    String -> a XmlTree XmlTree
    hasAttr String
    attrName
                    XmlArrow -> XmlArrow -> XmlArrow
    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 (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 av :: 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 (t :: * -> *) a. Foldable t => t a -> Bool
    null [String]
    valueList
                          = String -> XmlArrow
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "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]
    ++
                                  " 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]
    ++
                                  " must have at least one name."
                                )
                      | Bool
    otherwise
                          = [XmlArrow] -> XmlArrow
    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  attrValue :: String
    attrValue
                  = if String
    attrValue String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String]
    idValueList
                    then XmlArrow
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
                    else String -> XmlArrow
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "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]
    ++
                               " 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 idAttrTypes :: 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 (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 (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 (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& SLA [String] XmlTree XmlTree
    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 name :: String
    name x :: XmlTree
    x
              = SLA [String] XmlTree [String]
    -> SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    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 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 (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (String
    attrValue String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem`)
                    )
                (String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "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]
    ++ " 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]
    ++ " must be unique within the document." ))
                (([String] -> [String]) -> SLA [String] XmlTree [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 (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 idRefEnv :: IdEnvTable
    idRefEnv
        = IdEnvTable -> XmlArrow
    traverseTree IdEnvTable
    idRefEnv

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