{-# LANGUAGE FlexibleContexts #-}

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

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

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

   This module provides functions for validating the DTD of XML documents
   represented as XmlTree.

   Unlike other popular XML validation tools the validation process returns
   a list of errors instead of aborting after the first error was found.


   Unlike validation of the document, the DTD branch is traversed four times:

    - Validation of Notations

    - Validation of Unparsed Entities

    - Validation of Element declarations

    - Validation of Attribute declarations

-}

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

module Text.XML.HXT.DTDValidation.DTDValidation
    ( removeDoublicateDefs
    , validateDTD
    )
where

import           Text.XML.HXT.DTDValidation.AttributeValueValidation
import           Text.XML.HXT.DTDValidation.TypeDefs

-- |
-- Validate a DTD.
--
--    - returns : a functions which takes the DTD subset of the XmlTree, checks
--                  if the DTD is valid and returns a list of errors

validateDTD :: XmlArrow
validateDTD :: XmlArrow
validateDTD -- dtdPart
    = forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype
      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]
listA 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
>>>
        ( [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateParts forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<< (LA [XmlTree] [[Char]]
getNotationNames forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& LA [XmlTree] [[Char]]
getElemNames) )
      )
    where
    validateParts :: [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateParts [[Char]]
notationNames [[Char]]
elemNames
        = LA [XmlTree] XmlTree
validateNotations
          forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
          [[Char]] -> LA [XmlTree] XmlTree
validateEntities [[Char]]
notationNames
          forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
          [[Char]] -> LA [XmlTree] XmlTree
validateElements [[Char]]
elemNames
          forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
          [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateAttributes [[Char]]
elemNames [[Char]]
notationNames

    getNotationNames    :: LA [XmlTree] [String]
    getNotationNames :: LA [XmlTree] [[Char]]
getNotationNames    = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation 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 => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name

    getElemNames        :: LA [XmlTree] [String]
    getElemNames :: LA [XmlTree] [[Char]]
getElemNames        = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall a b. (a -> b) -> a -> b
$ 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement  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 => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name

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

checkName       :: String -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
checkName :: [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name SLA [[Char]] XmlTree XmlTree
msg
    = 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 ([Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
          )
      SLA [[Char]] XmlTree XmlTree
msg
      (forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState ([Char]
nameforall 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)

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

-- |
-- Validation of Notations, checks if all notation names are unique.
-- Validity constraint: Unique Notation Name (4.7 \/ p.44 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - returns : a list of errors

validateNotations :: LA XmlTrees XmlTree
validateNotations :: LA [XmlTree] XmlTree
validateNotations
    = 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation
                   forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                   (Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                 )
      where
      checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
      checkForUniqueNotation :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation Attributes
al
          = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
            forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Notation "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" was already specified." )
          where
          name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al

-- |
-- Validation of Entities.
--
-- 1. Issues a warning if entities are declared multiple times.
--
--    Optional warning: (4.2 \/ p.35 in Spec)
--
--
-- 2. Validates that a notation is declared for an unparsed entity.
--
--    Validity constraint: Notation Declared (4.2.2 \/ p.36 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter notationNames :  list of all notation names declared in the DTD
--
--    - returns : a list of errors

validateEntities        :: [String] -> LA XmlTrees XmlTree
validateEntities :: [[Char]] -> LA [XmlTree] XmlTree
validateEntities [[Char]]
notationNames
    = ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity
                     forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                     (Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueEntity forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                   )
      )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isUnparsedEntity
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (Attributes -> XmlArrow
checkNotationDecl forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
      )
      where

      -- Check if entities are declared multiple times

      checkForUniqueEntity      :: Attributes -> SLA [String] XmlTree XmlTree
      checkForUniqueEntity :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueEntity Attributes
al
          = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
            forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Entity "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
" was already specified. " forall a. [a] -> [a] -> [a]
++
                    [Char]
"First declaration will be used." )
          where
          name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al

      -- Find unparsed entities for which no notation is specified

      checkNotationDecl         :: Attributes -> XmlArrow
      checkNotationDecl :: Attributes -> XmlArrow
checkNotationDecl Attributes
al
          | [Char]
notationName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
notationNames
              = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          | Bool
otherwise
              = forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The notation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
notationName forall a. [a] -> [a] -> [a]
++ [Char]
" must be declared " forall a. [a] -> [a] -> [a]
++
                      [Char]
"when referenced in the unparsed entity declaration for " forall a. [a] -> [a] -> [a]
++
                      forall a. Show a => a -> [Char]
show [Char]
upEntityName forall a. [a] -> [a] -> [a]
++ [Char]
"."
                    )
          where
          notationName :: [Char]
notationName = forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 [Char]
k_ndata Attributes
al
          upEntityName :: [Char]
upEntityName = Attributes -> [Char]
dtd_name  Attributes
al

-- |
-- Validation of Element declarations.
--
-- 1. Validates that an element is not declared multiple times.
--
--    Validity constraint: Unique Element Type Declaration (3.2 \/ p.21 in Spec)
--
--
-- 2. Validates that an element name only appears once in a mixed-content declaration.
--
--    Validity constraint: No Duplicate Types (3.2 \/ p.21 in Spec)
--
--
-- 3. Issues a warning if an element mentioned in a content model is not declared in the
--    DTD.
--
--    Optional warning: (3.2 \/ p.21 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter elemNames :  list of all element names declared in the DTD
--
--    - returns : a list of errors


validateElements        :: [String] -> LA XmlTrees XmlTree
validateElements :: [[Char]] -> LA [XmlTree] XmlTree
validateElements [[Char]]
elemNames -- dtdPart
    = ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement
                     forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                     (Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueElement forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                   )
      )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isMixedContentElement
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (Attributes -> XmlArrow
checkMixedContent forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
      )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        ([[Char]] -> Attributes -> XmlArrow
checkContentModel [[Char]]
elemNames forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
      )
      where

      -- Validates that an element is not declared multiple times

      checkForUniqueElement :: Attributes -> SLA [String] XmlTree XmlTree
      checkForUniqueElement :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueElement Attributes
al
          = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
            forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++
                  [Char]
" must not be declared more than once." )
          where
          name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al

      -- Validates that an element name only appears once in a mixed-content declaration

      checkMixedContent :: Attributes -> XmlArrow
      checkMixedContent :: Attributes -> XmlArrow
checkMixedContent Attributes
al
          = forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( 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 :: * -> * -> *) (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
isDTDName
                         forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                         (Attributes -> SLA [[Char]] XmlTree XmlTree
check forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                       )
            where
            elemName :: [Char]
elemName = Attributes -> [Char]
dtd_name Attributes
al
            check :: Attributes -> SLA [[Char]] XmlTree XmlTree
check Attributes
al'
                = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
                  forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The element type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
name forall a. [a] -> [a] -> [a]
++
                         [Char]
" was already specified in the mixed-content model of the element declaration " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> [Char]
show [Char]
elemName forall a. [a] -> [a] -> [a]
++ [Char]
"." )
                where
                name :: [Char]
name = Attributes -> [Char]
dtd_name Attributes
al'

      -- Issues a warning if an element mentioned in a content model is not
      -- declared in the DTD.
      checkContentModel :: [String] -> Attributes -> XmlArrow
      checkContentModel :: [[Char]] -> Attributes -> XmlArrow
checkContentModel [[Char]]
names Attributes
al
          | [Char]
cm forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
v_children, [Char]
v_mixed]
              = 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
>>> XmlArrow
checkContent
          | Bool
otherwise
              = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          where
          elemName :: [Char]
elemName = Attributes -> [Char]
dtd_name Attributes
al
          cm :: [Char]
cm       = Attributes -> [Char]
dtd_type Attributes
al

          checkContent :: XmlArrow
          checkContent :: XmlArrow
checkContent
              = forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
                [ forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName    forall a b. a -> b -> IfThen a b
:-> ( forall {a :: * -> * -> *} {b}.
ArrowXml a =>
Attributes -> a b XmlTree
checkName' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl )
                , forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDContent forall a b. a -> b -> IfThen a b
:-> ( 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
>>> XmlArrow
checkContent )
                , forall (a :: * -> * -> *) b. ArrowList a => a b b
this         forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                ]
              where
              checkName' :: Attributes -> a b XmlTree
checkName' Attributes
al'
                  | [Char]
childElemName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
names
                      = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                  | Bool
otherwise
                      = forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"The element type "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
childElemName forall a. [a] -> [a] -> [a]
++
                               [Char]
", used in content model of element "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
elemName forall a. [a] -> [a] -> [a]
++
                               [Char]
", is not declared."
                             )
                  where
                  childElemName :: [Char]
childElemName = Attributes -> [Char]
dtd_name Attributes
al'

-- |
-- Validation of Attribute declarations.
--
-- (1) Issues a warning if an attribute is declared for an element type not itself
--    decared.
--
--    Optinal warning: (3.3 \/ p. 24 in Spec)
--
--
-- 2. Issues a warning if more than one definition is provided for the same
--    attribute of a given element type. Fist declaration is binding, later
--    definitions are ignored.
--
--    Optional warning: (3.3 \/ p.24 in Spec)
--
--
-- 3. Issues a warning if the same Nmtoken occures more than once in enumerated
--    attribute types of a single element type.
--
--    Optional warning: (3.3.1 \/ p.27 in Spec)
--
--
-- 4. Validates that an element type has not more than one ID attribute defined.
--
--    Validity constraint: One ID per Element Type (3.3.1 \/ p.26 in Spec)
--
--
-- 5. Validates that an element type has not more than one NOTATION attribute defined.
--
--    Validity constraint: One Notation per Element Type (3.3.1 \/ p.27 in Spec)
--
--
-- 6. Validates that an ID attributes has the type #IMPLIED or #REQUIRED.
--
--    Validity constraint: ID Attribute Default (3.3.1 \/ p.26 in Spec)
--
--
-- 7. Validates that all referenced notations are declared.
--
--    Validity constraint: Notation Attributes (3.3.1 \/ p.27 in Spec)
--
--
-- 8. Validates that notations are not declared for EMPTY elements.
--
--    Validity constraint: No Notation on Empty Element (3.3.1 \/p.27 in Spec)
--
--
-- 9. Validates that the default value matches the lexical constraints of it's type.
--
--    Validity constraint: Attribute default legal (3.3.2 \/ p.28 in Spec)
--
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter elemNames :  list of all element names declared in the DTD
--
--    - 3.parameter notationNames :  list of all notation names declared in the DTD
--
--    - returns : a list of errors

validateAttributes :: [String] -> [String] -> LA XmlTrees XmlTree
validateAttributes :: [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateAttributes [[Char]]
elemNames [[Char]]
notationNames
    = -- 1. Find attributes for which no elements are declared
      ( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck forall (a :: * -> * -> *) b. ArrowList a => a b b
this ([[Char]] -> Attributes -> XmlArrow
checkDeclaredElements [[Char]]
elemNames) )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 2. Find attributes which are declared more than once
      ( forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck forall (a :: * -> * -> *) b. ArrowList a => a b b
this Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueAttributeDeclaration )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 3. Find enumerated attribute types which nmtokens are declared more than once
      ( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck (forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isEnumAttrType forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse` forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType) Attributes -> XmlArrow
checkEnumeratedTypes )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 4. Validate that there exists only one ID attribute for an element
      ( forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueId )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 5. Validate that there exists only one NOTATION attribute for an element
      ( forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
      ( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType Attributes -> XmlArrow
checkIdKindConstraint )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 7. Validate that all referenced notations are declared
      ( forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType ([[Char]] -> Attributes -> XmlArrow
checkNotationDeclaration [[Char]]
notationNames) )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 8. Validate that notations are not declared for EMPTY elements
      ( [[Char]] -> LA [XmlTree] XmlTree
checkNoNotationForEmptyElements 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 ( 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isEmptyElement
                                                   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 => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name
                                                 )
      )
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      -- 9. Validate that the default value matches the lexical constraints of it's type
      ( [XmlTree] -> LA [XmlTree] XmlTree
checkDefaultValueTypes forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b. ArrowList a => a b b
this )

      where
      -- ------------------------------------------------------------
      -- control structures

      runCheck :: cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck cat XmlTree XmlTree
select Attributes -> cat XmlTree c
check
          = 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            cat XmlTree XmlTree
select
            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            (Attributes -> cat XmlTree c
check forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)

      runNameCheck :: SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck SLA [a] XmlTree XmlTree
select Attributes -> SLA [a] XmlTree c
check
          = forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] forall a b. (a -> b) -> a -> b
$ forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck SLA [a] XmlTree XmlTree
select Attributes -> SLA [a] XmlTree c
check

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

      -- 1. Find attributes for which no elements are declared

      checkDeclaredElements :: [String] -> Attributes -> XmlArrow
      checkDeclaredElements :: [[Char]] -> Attributes -> XmlArrow
checkDeclaredElements [[Char]]
elemNames' Attributes
al
          | [Char]
en forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
elemNames'
              = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          | Bool
otherwise
              = forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"The element type \""forall a. [a] -> [a] -> [a]
++ [Char]
en forall a. [a] -> [a] -> [a]
++ [Char]
"\" used in dclaration "forall a. [a] -> [a] -> [a]
++
                       [Char]
"of attribute \""forall a. [a] -> [a] -> [a]
++ [Char]
an forall a. [a] -> [a] -> [a]
++[Char]
"\" is not declared."
                     )
          where
          en :: [Char]
en = Attributes -> [Char]
dtd_name Attributes
al
          an :: [Char]
an = Attributes -> [Char]
dtd_value Attributes
al

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

      -- 2. Find attributes which are declared more than once

      checkForUniqueAttributeDeclaration ::  Attributes -> SLA [String] XmlTree XmlTree
      checkForUniqueAttributeDeclaration :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueAttributeDeclaration Attributes
al
          = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
name forall a b. (a -> b) -> a -> b
$
            forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Attribute \""forall a. [a] -> [a] -> [a]
++ [Char]
aname forall a. [a] -> [a] -> [a]
++[Char]
"\" for element type \""forall a. [a] -> [a] -> [a]
++
                   [Char]
ename forall a. [a] -> [a] -> [a]
++[Char]
"\" is already declared. First "forall a. [a] -> [a] -> [a]
++
                   [Char]
"declaration will be used." )
          where
          ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al
          aname :: [Char]
aname = Attributes -> [Char]
dtd_value Attributes
al
          name :: [Char]
name  = [Char]
ename forall a. [a] -> [a] -> [a]
++ [Char]
"|" forall a. [a] -> [a] -> [a]
++ [Char]
aname

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

      -- 3. Find enumerated attribute types which nmtokens are declared more than once

      checkEnumeratedTypes :: Attributes -> XmlArrow
      checkEnumeratedTypes :: Attributes -> XmlArrow
checkEnumeratedTypes Attributes
al
          = forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( 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
isDTDName
                         forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                         (Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueType forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                       )
          where
          checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree
          checkForUniqueType :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueType Attributes
al'
              = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
nmtoken forall a b. (a -> b) -> a -> b
$
                forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Nmtoken \""forall a. [a] -> [a] -> [a]
++ [Char]
nmtoken forall a. [a] -> [a] -> [a]
++[Char]
"\" should not "forall a. [a] -> [a] -> [a]
++
                       [Char]
"occur more than once in attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++
                       [Char]
"\" for element \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_name Attributes
al forall a. [a] -> [a] -> [a]
++ [Char]
"\"." )
              where
              nmtoken :: [Char]
nmtoken = Attributes -> [Char]
dtd_name Attributes
al'

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

      -- 4. Validate that there exists only one ID attribute for an element

      checkForUniqueId :: Attributes -> SLA [String] XmlTree XmlTree
      checkForUniqueId :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueId Attributes
al
          = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
ename forall a b. (a -> b) -> a -> b
$
            forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element \""forall a. [a] -> [a] -> [a]
++ [Char]
ename forall a. [a] -> [a] -> [a]
++ [Char]
"\" already has attribute of type "forall a. [a] -> [a] -> [a]
++
                  [Char]
"ID, another attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++ [Char]
"\" of type ID is "forall a. [a] -> [a] -> [a]
++
                  [Char]
"not permitted." )
          where
          ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al

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

      -- 5. Validate that there exists only one NOTATION attribute for an element

      checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
      checkForUniqueNotation :: Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation Attributes
al
          = [Char]
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
checkName [Char]
ename forall a b. (a -> b) -> a -> b
$
            forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element \""forall a. [a] -> [a] -> [a]
++ [Char]
ename forall a. [a] -> [a] -> [a]
++ [Char]
"\" already has attribute of type "forall a. [a] -> [a] -> [a]
++
                  [Char]
"NOTATION, another attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++ [Char]
"\" of type NOTATION "forall a. [a] -> [a] -> [a]
++
                  [Char]
"is not permitted." )
          where
          ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al

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

      -- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED

      checkIdKindConstraint :: Attributes -> XmlArrow
      checkIdKindConstraint :: Attributes -> XmlArrow
checkIdKindConstraint Attributes
al
          | [Char]
attKind forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
k_implied, [Char]
k_required]
              = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          | Bool
otherwise
              = forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"ID attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++[Char]
"\" must have a declared default "forall a. [a] -> [a] -> [a]
++
                      [Char]
"of \"#IMPLIED\" or \"REQUIRED\"")
          where
          attKind :: [Char]
attKind = Attributes -> [Char]
dtd_kind Attributes
al


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

      -- 7. Validate that all referenced notations are declared

      checkNotationDeclaration :: [String] -> Attributes -> XmlArrow
      checkNotationDeclaration :: [[Char]] -> Attributes -> XmlArrow
checkNotationDeclaration [[Char]]
notations Attributes
al
          = 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
isDTDName
            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            (Attributes -> XmlArrow
checkNotations forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
          where
          checkNotations :: Attributes -> XmlArrow
          checkNotations :: Attributes -> XmlArrow
checkNotations Attributes
al'
              | [Char]
notation forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
notations
                  = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
              | Bool
otherwise
                  = forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The notation \""forall a. [a] -> [a] -> [a]
++ [Char]
notation forall a. [a] -> [a] -> [a]
++[Char]
"\" must be declared when "forall a. [a] -> [a] -> [a]
++
                          [Char]
"referenced in the notation type list for attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++
                          [Char]
"\" of element \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_name Attributes
al forall a. [a] -> [a] -> [a]
++[Char]
"\"."
                        )
              where
              notation :: [Char]
notation = Attributes -> [Char]
dtd_name Attributes
al'

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

      -- 8. Validate that notations are not declared for EMPTY elements

      checkNoNotationForEmptyElements :: [String] -> LA XmlTrees XmlTree
      checkNoNotationForEmptyElements :: [[Char]] -> LA [XmlTree] XmlTree
checkNoNotationForEmptyElements [[Char]]
emptyElems
          = 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
            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
isNotationAttrType
            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            (Attributes -> XmlArrow
checkNoNotationForEmptyElement forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
          where
          checkNoNotationForEmptyElement :: Attributes -> XmlArrow
          checkNoNotationForEmptyElement :: Attributes -> XmlArrow
checkNoNotationForEmptyElement Attributes
al
              | [Char]
ename forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
emptyElems
                  = forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Attribute \""forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al forall a. [a] -> [a] -> [a]
++[Char]
"\" of type NOTATION must not be "forall a. [a] -> [a] -> [a]
++
                          [Char]
"declared on the element \""forall a. [a] -> [a] -> [a]
++ [Char]
ename forall a. [a] -> [a] -> [a]
++[Char]
"\" declared EMPTY."
                        )
              | Bool
otherwise
                  = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
              where
              ename :: [Char]
ename = Attributes -> [Char]
dtd_name Attributes
al

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

      -- 9. Validate that default values meet the lexical constraints of the attribute types

      checkDefaultValueTypes :: XmlTrees -> LA XmlTrees XmlTree
      checkDefaultValueTypes :: [XmlTree] -> LA [XmlTree] XmlTree
checkDefaultValueTypes [XmlTree]
dtdPart'
          = 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 :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
            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
isDefaultAttrKind
            forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ([XmlTree] -> XmlTree -> XmlArrow
checkAttributeValue [XmlTree]
dtdPart' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *) b. ArrowList a => a b b
this)

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

-- |
-- Removes doublicate declarations from the DTD, which first declaration is
-- binding. This is the case for ATTLIST and ENTITY declarations.
--
--    - returns : A function that replaces the children of DOCTYPE nodes by a list
--               where all multiple declarations are removed.

removeDoublicateDefs :: XmlArrow
removeDoublicateDefs :: XmlArrow
removeDoublicateDefs
    = forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
      ( forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( 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 :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist forall a b. a -> b -> IfThen a b
:-> (Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleAttlist forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                             , forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity  forall a b. a -> b -> IfThen a b
:-> (Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleEntity  forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                             , forall (a :: * -> * -> *) b. ArrowList a => a b b
this         forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                             ]
                   )
      )
      forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
      forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype
    where
    checkName' :: a -> a d d
checkName' a
n'
        = 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 (a
n' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
              )
          forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          (forall (a :: * -> * -> *) b. ArrowList a => a b b
this 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 -> a b b
perform (forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState (a
n'forall a. a -> [a] -> [a]
:)))

    removeDoubleAttlist :: Attributes -> SLA [String] XmlTree XmlTree
    removeDoubleAttlist :: Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleAttlist Attributes
al
        = forall {a} {a :: * -> * -> *} {d}.
(ArrowState [a] a, Eq a, ArrowIf a) =>
a -> a d d
checkName' [Char]
elemAttr
        where
        elemAttr :: [Char]
elemAttr = [Char]
elemName forall a. [a] -> [a] -> [a]
++ [Char]
"|" forall a. [a] -> [a] -> [a]
++ [Char]
attrName
        attrName :: [Char]
attrName = Attributes -> [Char]
dtd_value Attributes
al
        elemName :: [Char]
elemName = Attributes -> [Char]
dtd_name Attributes
al

    removeDoubleEntity  :: Attributes -> SLA [String] XmlTree XmlTree
    removeDoubleEntity :: Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleEntity Attributes
al
        = forall {a} {a :: * -> * -> *} {d}.
(ArrowState [a] a, Eq a, ArrowIf a) =>
a -> a d d
checkName' (Attributes -> [Char]
dtd_name Attributes
al)

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