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

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

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

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

    checkName       :: String -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName :: String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName name :: String
    name msg :: SLA [String] XmlTree XmlTree
    msg
        = SLA [String] XmlTree [String]
    -> SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d -> a b d
    ifA ( SLA [String] XmlTree [String]
    forall s (a :: * -> * -> *) b. ArrowState s a => a b s
    getState
                SLA [String] XmlTree [String]
    -> SLA [String] [String] [String] -> SLA [String] XmlTree [String]
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                ([String] -> Bool) -> SLA [String] [String] [String]
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (String
    name String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem`)
              )
          SLA [String] XmlTree XmlTree
    msg
          (([String] -> [String]) -> SLA [String] XmlTree [String]
    forall s (a :: * -> * -> *) b. ArrowState s a => (s -> s) -> a b s
    nextState (String
    nameString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :) SLA [String] XmlTree [String]
    -> SLA [String] [String] XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> SLA [String] [String] XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none)

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

    -- |
    -- 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
        = [String] -> SLA [String] [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA [] ( SLA [String] [XmlTree] XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a [b] b
    unlistA
                       SLA [String] [XmlTree] XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] [XmlTree] XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                       SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDNotation
                       SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                       (Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueNotation (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                     )
          where
          checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
          checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueNotation al :: Attributes
    al
              = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    name (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "Notation "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " was already specified." )
              where
              name :: String
    name = Attributes -> String
    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 :: [String] -> LA [XmlTree] XmlTree
    validateEntities notationNames :: [String]
    notationNames
        = ( [String] -> SLA [String] [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA [] ( SLA [String] [XmlTree] XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a [b] b
    unlistA
                         SLA [String] [XmlTree] XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] [XmlTree] XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                         SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDEntity
                         SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                         (Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueEntity (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                       )
          )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) b c.
    ArrowPlus a =>
    a b c -> a b c -> a b c
    <+>
          ( LA [XmlTree] XmlTree
    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 (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 [String] XmlTree XmlTree
    checkForUniqueEntity al :: Attributes
    al
              = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    name (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    warn ( "Entity "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " was already specified. " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                        "First declaration will be used." )
              where
              name :: String
    name = Attributes -> String
    dtd_name Attributes
    al

          -- Find unparsed entities for which no notation is specified

          checkNotationDecl         :: Attributes -> XmlArrow
          checkNotationDecl :: Attributes -> XmlArrow
    checkNotationDecl al :: Attributes
    al
              | String
    notationName String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String]
    notationNames
                  = XmlArrow
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
              | Bool
    otherwise
                  = String -> XmlArrow
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "The notation " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    notationName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " must be declared " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                          "when referenced in the unparsed entity declaration for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                          String -> String
    forall a. Show a => a -> String
    show String
    upEntityName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "."
                        )
              where
              notationName :: String
    notationName = String -> Attributes -> String
    forall k e. Eq k => k -> AssocList k [e] -> [e]
    lookup1 String
    k_ndata Attributes
    al
              upEntityName :: String
    upEntityName = Attributes -> String
    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 :: [String] -> LA [XmlTree] XmlTree
    validateElements elemNames :: [String]
    elemNames -- dtdPart
        = ( [String] -> SLA [String] [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA [] ( SLA [String] [XmlTree] XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a [b] b
    unlistA
                         SLA [String] [XmlTree] XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] [XmlTree] XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                         SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDElement
                         SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                         (Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueElement (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                       )
          )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) b c.
    ArrowPlus a =>
    a b c -> a b c -> a b c
    <+>
          ( LA [XmlTree] XmlTree
    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 (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 (a :: * -> * -> *) b c.
    ArrowPlus a =>
    a b c -> a b c -> a b c
    <+>
          ( LA [XmlTree] XmlTree
    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
    >>>
            ([String] -> Attributes -> XmlArrow
    checkContentModel [String]
    elemNames (Attributes -> XmlArrow) -> LA XmlTree Attributes -> XmlArrow
    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 [String] XmlTree XmlTree
    checkForUniqueElement al :: Attributes
    al
              = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    name (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "Element type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                      " must not be declared more than once." )
              where
              name :: String
    name = Attributes -> String
    dtd_name Attributes
    al

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

          checkMixedContent :: Attributes -> XmlArrow
          checkMixedContent :: Attributes -> XmlArrow
    checkMixedContent al :: Attributes
    al
              = [String] -> SLA [String] XmlTree XmlTree -> XmlArrow
    forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA [] ( SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                             SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                             SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                             SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                             SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDName
                             SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                             (Attributes -> SLA [String] XmlTree XmlTree
    check (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                           )
                where
                elemName :: String
    elemName = Attributes -> String
    dtd_name Attributes
    al
                check :: Attributes -> SLA [String] XmlTree XmlTree
    check al' :: Attributes
    al'
                    = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    name (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                      String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "The element type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                             " was already specified in the mixed-content model of the element declaration " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                             String -> String
    forall a. Show a => a -> String
    show String
    elemName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "." )
                    where
                    name :: String
    name = Attributes -> String
    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 :: [String] -> Attributes -> XmlArrow
    checkContentModel names :: [String]
    names al :: Attributes
    al
              | String
    cm String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String
    v_children, String
    v_mixed]
                  = XmlArrow
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren XmlArrow -> XmlArrow -> XmlArrow
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> XmlArrow
    checkContent
              | Bool
    otherwise
                  = XmlArrow
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
              where
              elemName :: String
    elemName = Attributes -> String
    dtd_name Attributes
    al
              cm :: String
    cm       = Attributes -> String
    dtd_type Attributes
    al

              checkContent :: XmlArrow
              checkContent :: XmlArrow
    checkContent
                  = [IfThen XmlArrow XmlArrow] -> XmlArrow
    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 (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 (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 (a :: * -> * -> *) b. ArrowList a => a b b
    this         XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
    forall a b. a -> b -> IfThen a b
    :-> XmlArrow
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
                    ]
                  where
                  checkName' :: Attributes -> a b XmlTree
    checkName' al' :: Attributes
    al'
                      | String
    childElemName String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String]
    names
                          = a b XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
                      | Bool
    otherwise
                          = String -> a b XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    warn ( "The element type "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    childElemName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                   ", used in content model of element "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    elemName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                   ", is not declared."
                                 )
                      where
                      childElemName :: String
    childElemName = Attributes -> String
    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 :: [String] -> [String] -> LA [XmlTree] XmlTree
    validateAttributes elemNames :: [String]
    elemNames notationNames :: [String]
    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 (a :: * -> * -> *) b. ArrowList a => a b b
    this ([String] -> Attributes -> XmlArrow
    checkDeclaredElements [String]
    elemNames) )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    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 [String] XmlTree XmlTree
    -> (Attributes -> SLA [String] 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 [String] XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueAttributeDeclaration )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    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 (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 (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 [String] XmlTree XmlTree
    -> (Attributes -> SLA [String] 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 [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isIdAttrType Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueId )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    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 [String] XmlTree XmlTree
    -> (Attributes -> SLA [String] 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 [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isNotationAttrType Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueNotation )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    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 (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 ([String] -> Attributes -> XmlArrow
    checkNotationDeclaration [String]
    notationNames) )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    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
          ( [String] -> LA [XmlTree] XmlTree
    checkNoNotationForEmptyElements ([String] -> LA [XmlTree] XmlTree)
    -> LA [XmlTree] [String] -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< LA [XmlTree] String -> LA [XmlTree] [String]
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
    listA ( LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a [b] b
    unlistA
                                                       LA [XmlTree] XmlTree -> LA XmlTree String -> LA [XmlTree] String
    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 String -> LA XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                                       String -> LA XmlTree String
    forall (a :: * -> * -> *). ArrowDTD a => String -> a XmlTree String
    getDTDAttrValue String
    a_name
                                                     )
          )
          LA [XmlTree] XmlTree
    -> LA [XmlTree] XmlTree -> LA [XmlTree] XmlTree
    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 (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< LA [XmlTree] [XmlTree]
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this )

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

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

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

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

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

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

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

          checkEnumeratedTypes :: Attributes -> XmlArrow
          checkEnumeratedTypes :: Attributes -> XmlArrow
    checkEnumeratedTypes al :: Attributes
    al
              = [String] -> SLA [String] XmlTree XmlTree -> XmlArrow
    forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA [] ( SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                             SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                             SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDName
                             SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                             (Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueType (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                           )
              where
              checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree
              checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree
    checkForUniqueType al' :: Attributes
    al'
                  = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    nmtoken (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                    String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    warn ( "Nmtoken \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    nmtoken String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++"\" should not "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                           "occur more than once in attribute \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Attributes -> String
    dtd_value Attributes
    al String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                           "\" for element \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Attributes -> String
    dtd_name Attributes
    al String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\"." )
                  where
                  nmtoken :: String
    nmtoken = Attributes -> String
    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 [String] XmlTree XmlTree
    checkForUniqueId al :: Attributes
    al
              = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    ename (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "Element \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ename String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\" already has attribute of type "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                      "ID, another attribute \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Attributes -> String
    dtd_value Attributes
    al String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\" of type ID is "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                      "not permitted." )
              where
              ename :: String
    ename = Attributes -> String
    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 [String] XmlTree XmlTree
    checkForUniqueNotation al :: Attributes
    al
              = String
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName String
    ename (SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall a b. (a -> b) -> a -> b
    $
                String -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "Element \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ename String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\" already has attribute of type "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                      "NOTATION, another attribute \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Attributes -> String
    dtd_value Attributes
    al String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\" of type NOTATION "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                      "is not permitted." )
              where
              ename :: String
    ename = Attributes -> String
    dtd_name Attributes
    al

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

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

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

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

          -- 7. Validate that all referenced notations are declared

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

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

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

          checkNoNotationForEmptyElements :: [String] -> LA XmlTrees XmlTree
          checkNoNotationForEmptyElements :: [String] -> LA [XmlTree] XmlTree
    checkNoNotationForEmptyElements emptyElems :: [String]
    emptyElems
              = LA [XmlTree] XmlTree
    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 (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 al :: Attributes
    al
                  | String
    ename String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String]
    emptyElems
                      = String -> XmlArrow
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "Attribute \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Attributes -> String
    dtd_value Attributes
    al String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++"\" of type NOTATION must not be "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                              "declared on the element \""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ename String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++"\" declared EMPTY."
                            )
                  | Bool
    otherwise
                      = XmlArrow
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
                  where
                  ename :: String
    ename = Attributes -> String
    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 dtdPart' :: [XmlTree]
    dtdPart'
              = LA [XmlTree] XmlTree
    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 (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< XmlArrow
    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 (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b) -> a (t b) (t b)
    replaceChildren
          ( [String] -> SLA [String] XmlTree XmlTree -> XmlArrow
    forall (a :: * -> * -> *) s b c.
    ArrowList a =>
    s -> SLA s b c -> a b c
    fromSLA [] ( SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                         SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                         [IfThen
       (SLA [String] XmlTree XmlTree) (SLA [String] XmlTree XmlTree)]
    -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA [ SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDAttlist SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    -> IfThen
         (SLA [String] XmlTree XmlTree) (SLA [String] XmlTree XmlTree)
    forall a b. a -> b -> IfThen a b
    :-> (Attributes -> SLA [String] XmlTree XmlTree
    removeDoubleAttlist (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                                 , SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
    isDTDEntity  SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    -> IfThen
         (SLA [String] XmlTree XmlTree) (SLA [String] XmlTree XmlTree)
    forall a b. a -> b -> IfThen a b
    :-> (Attributes -> SLA [String] XmlTree XmlTree
    removeDoubleEntity  (Attributes -> SLA [String] XmlTree XmlTree)
    -> SLA [String] XmlTree Attributes -> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< SLA [String] XmlTree Attributes
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
    getDTDAttrl)
                                 , SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this         SLA [String] XmlTree XmlTree
    -> SLA [String] XmlTree XmlTree
    -> IfThen
         (SLA [String] XmlTree XmlTree) (SLA [String] XmlTree XmlTree)
    forall a b. a -> b -> IfThen a b
    :-> SLA [String] XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this
                                 ]
                       )
          )
          XmlArrow -> XmlArrow -> XmlArrow
    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' n' :: a
    n'
            = a d [a] -> a d d -> a d d -> a d 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 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 (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (a
    n' a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem`)
                  )
              a d d
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
              (a d d
    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 (a :: * -> * -> *) b c. ArrowList a => a b c -> a b b
    perform (([a] -> [a]) -> a d [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 [String] XmlTree XmlTree
    removeDoubleAttlist al :: Attributes
    al
            = String -> SLA [String] XmlTree XmlTree
    forall a (a :: * -> * -> *) d.
    (ArrowState [a] a, Eq a, ArrowIf a) =>
    a -> a d d
    checkName' String
    elemAttr
            where
            elemAttr :: String
    elemAttr = String
    elemName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "|" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    attrName
            attrName :: String
    attrName = Attributes -> String
    dtd_value Attributes
    al
            elemName :: String
    elemName = Attributes -> String
    dtd_name Attributes
    al

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

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