{-# 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 [String]
notationNames [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 String
name 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 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 ( String
"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]
++ String
" 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 [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 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 ( String
"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]
++ String
" was already specified. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    String
"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 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 ( String
"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]
++ String
" must be declared " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"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]
++ String
"."
                    )
          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 [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 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 ( String
"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]
++
                  String
" 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 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 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 ( String
"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]
++
                         String
" 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]
++ String
"." )
                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 [String]
names 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' 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 ( String
"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]
++
                               String
", 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]
++
                               String
", 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 [String]
elemNames [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 cat XmlTree XmlTree
select 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 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 :: [String] -> Attributes -> XmlArrow
checkDeclaredElements [String]
elemNames' 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 ( String
"The element type \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
en String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" used in dclaration "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
"of attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
an String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" 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 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 ( String
"Attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
aname String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" for element type \""String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String
ename String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" is already declared. First "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   String
"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 -> 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 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 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 ( String
"Nmtoken \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nmtoken String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" should not "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
"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]
++
                       String
"\" for element \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attributes -> String
dtd_name Attributes
al String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"." )
              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 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 ( String
"Element \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" already has attribute of type "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"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]
++ String
"\" of type ID is "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"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 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 ( String
"Element \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" already has attribute of type "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"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]
++ String
"\" of type NOTATION "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"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 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 ( String
"ID attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attributes -> String
dtd_value Attributes
al String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" must have a declared default "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                      String
"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 [String]
notations 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 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 ( String
"The notation \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
notation String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" must be declared when "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
"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]
++
                          String
"\" of element \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attributes -> String
dtd_name Attributes
al String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\"."
                        )
              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 [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 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 ( String
"Attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attributes -> String
dtd_value Attributes
al String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" of type NOTATION must not be "String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
"declared on the element \""String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ename String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" 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 [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' 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 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 -> 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 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)

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