{-# 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
    = XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype
      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`
      ( XmlArrow -> LA XmlTree [XmlTree]
forall b c. LA b c -> LA b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA 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
        LA XmlTree [XmlTree] -> LA [XmlTree] XmlTree -> XmlArrow
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 ([[Char]] -> [[Char]] -> LA [XmlTree] XmlTree)
-> LA [XmlTree] ([[Char]], [[Char]]) -> LA [XmlTree] XmlTree
forall c1 c2 b d. (c1 -> c2 -> LA b d) -> LA b (c1, c2) -> LA b d
forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<< (LA [XmlTree] [[Char]]
getNotationNames LA [XmlTree] [[Char]]
-> LA [XmlTree] [[Char]] -> LA [XmlTree] ([[Char]], [[Char]])
forall b c c'. LA b c -> LA b c' -> LA b (c, c')
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
          LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
          [[Char]] -> LA [XmlTree] XmlTree
validateEntities [[Char]]
notationNames
          LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
          [[Char]] -> LA [XmlTree] XmlTree
validateElements [[Char]]
elemNames
          LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
          [[Char]] -> [[Char]] -> LA [XmlTree] XmlTree
validateAttributes [[Char]]
elemNames [[Char]]
notationNames

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

    getElemNames        :: LA [XmlTree] [String]
    getElemNames :: LA [XmlTree] [[Char]]
getElemNames        = LA [XmlTree] [Char] -> LA [XmlTree] [[Char]]
forall b c. LA b c -> LA b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (LA [XmlTree] [Char] -> LA [XmlTree] [[Char]])
-> LA [XmlTree] [Char] -> LA [XmlTree] [[Char]]
forall a b. (a -> b) -> a -> b
$ LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA LA [XmlTree] XmlTree -> LA XmlTree [Char] -> LA [XmlTree] [Char]
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  XmlArrow -> LA XmlTree [Char] -> LA XmlTree [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Char] -> LA XmlTree [Char]
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
    = SLA [[Char]] XmlTree [[Char]]
-> SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree
forall b c d.
SLA [[Char]] b c
-> SLA [[Char]] b d -> SLA [[Char]] b d -> SLA [[Char]] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( SLA [[Char]] XmlTree [[Char]]
forall b. SLA [[Char]] b [[Char]]
forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState
            SLA [[Char]] XmlTree [[Char]]
-> SLA [[Char]] [[Char]] [[Char]] -> SLA [[Char]] XmlTree [[Char]]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ([[Char]] -> Bool) -> SLA [[Char]] [[Char]] [[Char]]
forall b. (b -> Bool) -> SLA [[Char]] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ([Char]
name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
          )
      SLA [[Char]] XmlTree XmlTree
msg
      (([[Char]] -> [[Char]]) -> SLA [[Char]] XmlTree [[Char]]
forall b. ([[Char]] -> [[Char]]) -> SLA [[Char]] b [[Char]]
forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState ([Char]
name[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) SLA [[Char]] XmlTree [[Char]]
-> SLA [[Char]] [[Char]] XmlTree -> SLA [[Char]] 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 [[Char]] [[Char]] XmlTree
forall b c. SLA [[Char]] b 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
    = [[Char]] -> SLA [[Char]] [XmlTree] XmlTree -> LA [XmlTree] XmlTree
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( SLA [[Char]] [XmlTree] XmlTree
forall b. SLA [[Char]] [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
                   SLA [[Char]] [XmlTree] XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] [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 [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDNotation
                   SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
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 (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
            [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Notation "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
name [Char] -> [Char] -> [Char]
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
    = ( [[Char]] -> SLA [[Char]] [XmlTree] XmlTree -> LA [XmlTree] XmlTree
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( SLA [[Char]] [XmlTree] XmlTree
forall b. SLA [[Char]] [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
                     SLA [[Char]] [XmlTree] XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] [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 [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity
                     SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
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 (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                   )
      )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      ( LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
        LA [XmlTree] XmlTree -> XmlArrow -> LA [XmlTree] XmlTree
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
isUnparsedEntity
        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
>>>
        (Attributes -> XmlArrow
checkNotationDecl (Attributes -> XmlArrow) -> LA XmlTree Attributes -> 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 Attributes
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
            [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Entity "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" was already specified. " [Char] -> [Char] -> [Char]
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 [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
notationNames
              = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          | Bool
otherwise
              = [Char] -> XmlArrow
forall n. [Char] -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The notation " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
notationName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" must be declared " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char]
"when referenced in the unparsed entity declaration for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                      [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
upEntityName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
                    )
          where
          notationName :: [Char]
notationName = [Char] -> Attributes -> [Char]
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
    = ( [[Char]] -> SLA [[Char]] [XmlTree] XmlTree -> LA [XmlTree] XmlTree
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( SLA [[Char]] [XmlTree] XmlTree
forall b. SLA [[Char]] [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
                     SLA [[Char]] [XmlTree] XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] [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 [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDElement
                     SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
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 (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                   )
      )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      ( LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
        LA [XmlTree] XmlTree -> XmlArrow -> LA [XmlTree] XmlTree
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
isMixedContentElement
        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
>>>
        (Attributes -> XmlArrow
checkMixedContent (Attributes -> XmlArrow) -> LA XmlTree Attributes -> 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 Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
      )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      ( LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
        LA [XmlTree] XmlTree -> XmlArrow -> LA [XmlTree] XmlTree
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
        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
>>>
        ([[Char]] -> Attributes -> XmlArrow
checkContentModel [[Char]]
elemNames (Attributes -> XmlArrow) -> LA XmlTree Attributes -> 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 Attributes
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
            [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
name [Char] -> [Char] -> [Char]
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
          = [[Char]] -> SLA [[Char]] XmlTree XmlTree -> XmlArrow
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( SLA [[Char]] XmlTree XmlTree
forall (t :: * -> *) b. Tree t => SLA [[Char]] (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                         SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] 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 [[Char]] XmlTree XmlTree
forall (t :: * -> *) b. Tree t => SLA [[Char]] (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                         SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] 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 [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName
                         SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
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 (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                  [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The element type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                         [Char]
" was already specified in the mixed-content model of the element declaration " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                         [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
elemName [Char] -> [Char] -> [Char]
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 [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
v_children, [Char]
v_mixed]
              = 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
checkContent
          | Bool
otherwise
              = XmlArrow
forall b c. LA b c
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
              = [IfThen XmlArrow XmlArrow] -> XmlArrow
forall b c d. [IfThen (LA b c) (LA b d)] -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
                [ XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName    XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> ( Attributes -> XmlArrow
forall {a :: * -> * -> *} {b}.
ArrowXml a =>
Attributes -> a b XmlTree
checkName' (Attributes -> XmlArrow) -> LA XmlTree Attributes -> 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 Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl )
                , XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDContent XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> ( 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
checkContent )
                , XmlArrow
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this         XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                ]
              where
              checkName' :: Attributes -> a b XmlTree
checkName' Attributes
al'
                  | [Char]
childElemName [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
names
                      = a b XmlTree
forall b c. a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                  | Bool
otherwise
                      = [Char] -> a b XmlTree
forall n. [Char] -> a n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"The element type "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
childElemName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                               [Char]
", used in content model of element "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
elemName [Char] -> [Char] -> [Char]
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
      ( XmlArrow -> (Attributes -> XmlArrow) -> LA [XmlTree] XmlTree
forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck XmlArrow
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this ([[Char]] -> Attributes -> XmlArrow
checkDeclaredElements [[Char]]
elemNames) )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 2. Find attributes which are declared more than once
      ( SLA [[Char]] XmlTree XmlTree
-> (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> LA [XmlTree] XmlTree
forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck SLA [[Char]] XmlTree XmlTree
forall b. SLA [[Char]] b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueAttributeDeclaration )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 3. Find enumerated attribute types which nmtokens are declared more than once
      ( XmlArrow -> (Attributes -> XmlArrow) -> LA [XmlTree] XmlTree
forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck (XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isEnumAttrType XmlArrow -> XmlArrow -> XmlArrow
forall b c. LA b c -> LA b c -> LA b c
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse` XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType) Attributes -> XmlArrow
checkEnumeratedTypes )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 4. Validate that there exists only one ID attribute for an element
      ( SLA [[Char]] XmlTree XmlTree
-> (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> LA [XmlTree] XmlTree
forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck SLA [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueId )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 5. Validate that there exists only one NOTATION attribute for an element
      ( SLA [[Char]] XmlTree XmlTree
-> (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> LA [XmlTree] XmlTree
forall {a :: * -> * -> *} {a} {c}.
ArrowList a =>
SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> a [XmlTree] c
runNameCheck SLA [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType Attributes -> SLA [[Char]] XmlTree XmlTree
checkForUniqueNotation )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
      ( XmlArrow -> (Attributes -> XmlArrow) -> LA [XmlTree] XmlTree
forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isIdAttrType Attributes -> XmlArrow
checkIdKindConstraint )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 7. Validate that all referenced notations are declared
      ( XmlArrow -> (Attributes -> XmlArrow) -> LA [XmlTree] XmlTree
forall {cat :: * -> * -> *} {c}.
ArrowDTD cat =>
cat XmlTree XmlTree
-> (Attributes -> cat XmlTree c) -> cat [XmlTree] c
runCheck XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isNotationAttrType ([[Char]] -> Attributes -> XmlArrow
checkNotationDeclaration [[Char]]
notationNames) )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 8. Validate that notations are not declared for EMPTY elements
      ( [[Char]] -> LA [XmlTree] XmlTree
checkNoNotationForEmptyElements ([[Char]] -> LA [XmlTree] XmlTree)
-> LA [XmlTree] [[Char]] -> LA [XmlTree] XmlTree
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] [Char] -> LA [XmlTree] [[Char]]
forall b c. LA b c -> LA b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA ( LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
                                                   LA [XmlTree] XmlTree -> LA XmlTree [Char] -> LA [XmlTree] [Char]
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
isEmptyElement
                                                   XmlArrow -> LA XmlTree [Char] -> LA XmlTree [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                                                   [Char] -> LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowDTD a => [Char] -> a XmlTree [Char]
getDTDAttrValue [Char]
a_name
                                                 )
      )
      LA [XmlTree] XmlTree
-> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
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
<+>
      -- 9. Validate that the default value matches the lexical constraints of it's type
      ( [XmlTree] -> LA [XmlTree] XmlTree
checkDefaultValueTypes ([XmlTree] -> LA [XmlTree] XmlTree)
-> LA [XmlTree] [XmlTree] -> LA [XmlTree] XmlTree
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] [XmlTree]
forall b. LA b b
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
          = cat [XmlTree] XmlTree
forall b. cat [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA cat [XmlTree] XmlTree -> cat XmlTree c -> cat [XmlTree] c
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
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist
            cat XmlTree XmlTree -> cat XmlTree c -> cat XmlTree c
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
            cat XmlTree XmlTree -> cat XmlTree c -> cat XmlTree c
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 (Attributes -> cat XmlTree c)
-> cat XmlTree Attributes -> cat XmlTree c
forall c b d. (c -> cat b d) -> cat b c -> cat b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< cat XmlTree Attributes
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
          = [a] -> SLA [a] [XmlTree] c -> a [XmlTree] c
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] (SLA [a] [XmlTree] c -> a [XmlTree] c)
-> SLA [a] [XmlTree] c -> a [XmlTree] c
forall a b. (a -> b) -> a -> b
$ SLA [a] XmlTree XmlTree
-> (Attributes -> SLA [a] XmlTree c) -> SLA [a] [XmlTree] c
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 [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
elemNames'
              = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          | Bool
otherwise
              = [Char] -> XmlArrow
forall n. [Char] -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"The element type \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
en [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" used in dclaration "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                       [Char]
"of attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
an [Char] -> [Char] -> [Char]
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
            [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
aname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" for element type \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                   [Char]
ename [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" is already declared. First "[Char] -> [Char] -> [Char]
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 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"|" [Char] -> [Char] -> [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
          = [[Char]] -> SLA [[Char]] XmlTree XmlTree -> XmlArrow
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( SLA [[Char]] XmlTree XmlTree
forall (t :: * -> *) b. Tree t => SLA [[Char]] (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                         SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] 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 [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDName
                         SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
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 (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
                [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
warn ( [Char]
"Nmtoken \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nmtoken [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" should not "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                       [Char]
"occur more than once in attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                       [Char]
"\" for element \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_name Attributes
al [Char] -> [Char] -> [Char]
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
            [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ename [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" already has attribute of type "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char]
"ID, another attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" of type ID is "[Char] -> [Char] -> [Char]
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 (SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$
            [Char] -> SLA [[Char]] XmlTree XmlTree
forall n. [Char] -> SLA [[Char]] n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Element \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ename [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" already has attribute of type "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                  [Char]
"NOTATION, another attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\" of type NOTATION "[Char] -> [Char] -> [Char]
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 [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
k_implied, [Char]
k_required]
              = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          | Bool
otherwise
              = [Char] -> XmlArrow
forall n. [Char] -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"ID attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" must have a declared default "[Char] -> [Char] -> [Char]
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
          = 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
isDTDName
            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
>>>
            (Attributes -> XmlArrow
checkNotations (Attributes -> XmlArrow) -> LA XmlTree Attributes -> 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 Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
          where
          checkNotations :: Attributes -> XmlArrow
          checkNotations :: Attributes -> XmlArrow
checkNotations Attributes
al'
              | [Char]
notation [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
notations
                  = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
              | Bool
otherwise
                  = [Char] -> XmlArrow
forall n. [Char] -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"The notation \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
notation [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" must be declared when "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
"referenced in the notation type list for attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
"\" of element \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_name Attributes
al [Char] -> [Char] -> [Char]
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
          = LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA
            LA [XmlTree] XmlTree -> XmlArrow -> LA [XmlTree] XmlTree
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
            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
isNotationAttrType
            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
>>>
            (Attributes -> XmlArrow
checkNoNotationForEmptyElement (Attributes -> XmlArrow) -> LA XmlTree Attributes -> 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 Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
          where
          checkNoNotationForEmptyElement :: Attributes -> XmlArrow
          checkNoNotationForEmptyElement :: Attributes -> XmlArrow
checkNoNotationForEmptyElement Attributes
al
              | [Char]
ename [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
emptyElems
                  = [Char] -> XmlArrow
forall n. [Char] -> LA n XmlTree
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Attribute \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Attributes -> [Char]
dtd_value Attributes
al [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" of type NOTATION must not be "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
"declared on the element \""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ename [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\" declared EMPTY."
                        )
              | Bool
otherwise
                  = XmlArrow
forall b c. LA b c
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'
          = LA [XmlTree] XmlTree
forall b. LA [b] b
forall (a :: * -> * -> *) b. ArrowList a => a [b] b
unlistA LA [XmlTree] XmlTree -> XmlArrow -> LA [XmlTree] XmlTree
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
            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
isDefaultAttrKind
            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
>>>
            ([XmlTree] -> XmlTree -> XmlArrow
checkAttributeValue [XmlTree]
dtdPart' (XmlTree -> XmlArrow) -> XmlArrow -> 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
forall b. LA b b
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
    = XmlArrow -> XmlArrow
forall (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren
      ( [[Char]] -> SLA [[Char]] XmlTree XmlTree -> XmlArrow
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] ( SLA [[Char]] XmlTree XmlTree
forall (t :: * -> *) b. Tree t => SLA [[Char]] (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                     SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree -> SLA [[Char]] XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                     [IfThen
   (SLA [[Char]] XmlTree XmlTree) (SLA [[Char]] XmlTree XmlTree)]
-> SLA [[Char]] XmlTree XmlTree
forall b c d.
[IfThen (SLA [[Char]] b c) (SLA [[Char]] b d)] -> SLA [[Char]] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ SLA [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree
-> IfThen
     (SLA [[Char]] XmlTree XmlTree) (SLA [[Char]] XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> (Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleAttlist (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                             , SLA [[Char]] XmlTree XmlTree
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDEntity  SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree
-> IfThen
     (SLA [[Char]] XmlTree XmlTree) (SLA [[Char]] XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> (Attributes -> SLA [[Char]] XmlTree XmlTree
removeDoubleEntity  (Attributes -> SLA [[Char]] XmlTree XmlTree)
-> SLA [[Char]] XmlTree Attributes -> SLA [[Char]] XmlTree XmlTree
forall c b d.
(c -> SLA [[Char]] b d) -> SLA [[Char]] b c -> SLA [[Char]] b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< SLA [[Char]] XmlTree Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl)
                             , SLA [[Char]] XmlTree XmlTree
forall b. SLA [[Char]] b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this         SLA [[Char]] XmlTree XmlTree
-> SLA [[Char]] XmlTree XmlTree
-> IfThen
     (SLA [[Char]] XmlTree XmlTree) (SLA [[Char]] XmlTree XmlTree)
forall a b. a -> b -> IfThen a b
:-> SLA [[Char]] XmlTree XmlTree
forall b. SLA [[Char]] b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
                             ]
                   )
      )
      XmlArrow -> XmlArrow -> XmlArrow
forall b c. LA b b -> LA b c -> LA b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
      XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDDoctype
    where
    checkName' :: a -> a d d
checkName' a
n'
        = a d [a] -> a d d -> a d d -> a d d
forall b c d. a b c -> a b d -> a b d -> a b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( a d [a]
forall b. a b [a]
forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState
                a d [a] -> a [a] [a] -> a d [a]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                ([a] -> Bool) -> a [a] [a]
forall b. (b -> Bool) -> a b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (a
n' a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`)
              )
          a d d
forall b c. a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          (a d d
forall b. a b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this a d d -> a d d -> a d d
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a d [a] -> a d d
forall b c. a b c -> a b b
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
perform (([a] -> [a]) -> a d [a]
forall b. ([a] -> [a]) -> a b [a]
forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
nextState (a
n'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)))

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

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