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

    {- |
       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.TypeDefs
    import Text.XML.HXT.DTDValidation.AttributeValueValidation

    -- |
    -- 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 -- dtdPart
        = isDTDDoctype
          `guards`
          ( listA getChildren
            >>>
            ( validateParts $<< (getNotationNames &&& getElemNames) )
          )
        where
        validateParts notationNames elemNames
            = validateNotations
              <+>
              validateEntities notationNames
              <+>
              validateElements elemNames
              <+>
              validateAttributes elemNames notationNames

        getNotationNames    :: LA [XmlTree] [String]
        getNotationNames    = listA $ unlistA >>> isDTDNotation >>> getDTDAttrValue a_name

        getElemNames        :: LA [XmlTree] [String]
        getElemNames        = listA $ unlistA >>> isDTDElement  >>> getDTDAttrValue a_name

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

    checkName       :: String -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree
    checkName name msg
        = ifA ( getState
                >>>
                isA (name `elem`)
              )
          msg
          (nextState (name:) >>> 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
        = fromSLA [] ( unlistA
                       >>>
                       isDTDNotation
                       >>>
                       (checkForUniqueNotation $< getDTDAttrl)
                     )
          where
          checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree
          checkForUniqueNotation al
              = checkName name $
                err ( "Notation "++ show name ++ " was already specified." )
              where
              name = dtd_name 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 notationNames
        = ( fromSLA [] ( unlistA
                         >>>
                         isDTDEntity
                         >>>
                         (checkForUniqueEntity $< getDTDAttrl)
                       )
          )
          <+>
          ( unlistA
            >>>
            isUnparsedEntity
            >>>
            (checkNotationDecl $< getDTDAttrl)
          )
          where

          -- Check if entities are declared multiple times

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

          -- Find unparsed entities for which no notation is specified

          checkNotationDecl         :: Attributes -> XmlArrow
          checkNotationDecl al
              | notationName `elem` notationNames
                  = none
              | otherwise
                  = err ( "The notation " ++ show notationName ++ " must be declared " ++
                          "when referenced in the unparsed entity declaration for " ++
                          show upEntityName ++ "."
                        )
              where
              notationName = lookup1 k_ndata al
              upEntityName = dtd_name  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 elemNames -- dtdPart
        = ( fromSLA [] ( unlistA
                         >>>
                         isDTDElement
                         >>>
                         (checkForUniqueElement $< getDTDAttrl)
                       )
          )
          <+>
          ( unlistA
            >>>
            isMixedContentElement
            >>>
            (checkMixedContent $< getDTDAttrl)
          )
          <+>
          ( unlistA
            >>>
            isDTDElement
            >>>
            (checkContentModel elemNames $< getDTDAttrl)
          )
          where

          -- Validates that an element is not declared multiple times

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

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

          checkMixedContent :: Attributes -> XmlArrow
          checkMixedContent al
              = fromSLA [] ( getChildren
                             >>>
                             getChildren
                             >>>
                             isDTDName
                             >>>
                             (check $< getDTDAttrl)
                           )
                where
                elemName = dtd_name al
                check al'
                    = checkName name $
                      err ( "The element type " ++ show name ++
                             " was already specified in the mixed-content model of the element declaration " ++
                             show elemName ++ "." )
                    where
                    name = dtd_name al'

          -- Issues a warning if an element mentioned in a content model is not
          -- declared in the DTD.
          checkContentModel :: [String] -> Attributes -> XmlArrow
          checkContentModel names al
              | cm `elem` [v_children, v_mixed]
                  = getChildren >>> checkContent
              | otherwise
                  = none
              where
              elemName = dtd_name al
              cm       = dtd_type al

              checkContent :: XmlArrow
              checkContent
                  = choiceA
                    [ isDTDName    :-> ( checkName' $< getDTDAttrl )
                    , isDTDContent :-> ( getChildren >>> checkContent )
                    , this         :-> none
                    ]
                  where
                  checkName' al'
                      | childElemName `elem` names
                          = none
                      | otherwise
                          = warn ( "The element type "++ show childElemName ++
                                   ", used in content model of element "++ show elemName ++
                                   ", is not declared."
                                 )
                      where
                      childElemName = dtd_name 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 elemNames notationNames
        = -- 1. Find attributes for which no elements are declared
          ( runCheck this (checkDeclaredElements elemNames) )
          <+>
          -- 2. Find attributes which are declared more than once
          ( runNameCheck this checkForUniqueAttributeDeclaration )
          <+>
          -- 3. Find enumerated attribute types which nmtokens are declared more than once
          ( runCheck (isEnumAttrType `orElse` isNotationAttrType) checkEnumeratedTypes )
          <+>
          -- 4. Validate that there exists only one ID attribute for an element
          ( runNameCheck isIdAttrType checkForUniqueId )
          <+>
          -- 5. Validate that there exists only one NOTATION attribute for an element
          ( runNameCheck isNotationAttrType checkForUniqueNotation )
          <+>
          -- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
          ( runCheck isIdAttrType checkIdKindConstraint )
          <+>
          -- 7. Validate that all referenced notations are declared
          ( runCheck isNotationAttrType (checkNotationDeclaration notationNames) )
          <+>
          -- 8. Validate that notations are not declared for EMPTY elements
          ( checkNoNotationForEmptyElements $< listA ( unlistA
                                                       >>>
                                                       isEmptyElement
                                                       >>>
                                                       getDTDAttrValue a_name
                                                     )
          )
          <+>
          -- 9. Validate that the default value matches the lexical constraints of it's type
          ( checkDefaultValueTypes $< this )

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

          runCheck select check
              = unlistA >>> isDTDAttlist
                >>>
                select
                >>>
                (check $< getDTDAttrl)

          runNameCheck select check
              = fromSLA [] $ runCheck select check

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

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

          checkDeclaredElements :: [String] -> Attributes -> XmlArrow
          checkDeclaredElements elemNames' al
              | en `elem` elemNames'
                  = none
              | otherwise
                  = warn ( "The element type \""++ en ++ "\" used in dclaration "++
                           "of attribute \""++ an ++"\" is not declared."
                         )
              where
              en = dtd_name al
              an = dtd_value al

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

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

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

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

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

          checkEnumeratedTypes :: Attributes -> XmlArrow
          checkEnumeratedTypes al
              = fromSLA [] ( getChildren
                             >>>
                             isDTDName
                             >>>
                             (checkForUniqueType $< getDTDAttrl)
                           )
              where
              checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree
              checkForUniqueType al'
                  = checkName nmtoken $
                    warn ( "Nmtoken \""++ nmtoken ++"\" should not "++
                           "occur more than once in attribute \""++ dtd_value al ++
                           "\" for element \""++ dtd_name al ++ "\"." )
                  where
                  nmtoken = dtd_name al'

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

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

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

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

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

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

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

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

          checkIdKindConstraint :: Attributes -> XmlArrow
          checkIdKindConstraint al
              | attKind `elem` [k_implied, k_required]
                  = none
              | otherwise
                  = err ( "ID attribute \""++ dtd_value al ++"\" must have a declared default "++
                          "of \"#IMPLIED\" or \"REQUIRED\"")
              where
              attKind = dtd_kind al

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

          -- 7. Validate that all referenced notations are declared

          checkNotationDeclaration :: [String] -> Attributes -> XmlArrow
          checkNotationDeclaration notations al
              = getChildren
                >>>
                isDTDName
                >>>
                (checkNotations $< getDTDAttrl)
              where
              checkNotations :: Attributes -> XmlArrow
              checkNotations al'
                  | notation `elem` notations
                      = none
                  | otherwise
                      = err ( "The notation \""++ notation ++"\" must be declared when "++
                              "referenced in the notation type list for attribute \""++ dtd_value al ++
                              "\" of element \""++ dtd_name al ++"\"."
                            )
                  where
                  notation = dtd_name al'

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

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

          checkNoNotationForEmptyElements :: [String] -> LA XmlTrees XmlTree
          checkNoNotationForEmptyElements emptyElems
              = unlistA
                >>>
                isDTDAttlist
                >>>
                isNotationAttrType
                >>>
                (checkNoNotationForEmptyElement $< getDTDAttrl)
              where
              checkNoNotationForEmptyElement :: Attributes -> XmlArrow
              checkNoNotationForEmptyElement al
                  | ename `elem` emptyElems
                      = err ( "Attribute \""++ dtd_value al ++"\" of type NOTATION must not be "++
                              "declared on the element \""++ ename ++"\" declared EMPTY."
                            )
                  | otherwise
                      = none
                  where
                  ename = dtd_name al

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

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

          checkDefaultValueTypes :: XmlTrees -> LA XmlTrees XmlTree
          checkDefaultValueTypes dtdPart'
              = unlistA >>> isDTDAttlist
                >>>
                isDefaultAttrKind
                >>>
                (checkAttributeValue dtdPart' $< 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
        = replaceChildren
          ( fromSLA [] ( getChildren
                         >>>
                         choiceA [ isDTDAttlist :-> (removeDoubleAttlist $< getDTDAttrl)
                                 , isDTDEntity  :-> (removeDoubleEntity  $< getDTDAttrl)
                                 , this         :-> this
                                 ]
                       )
          )
          `when`
          isDTDDoctype
        where
        checkName' n'
            = ifA ( getState
                    >>>
                    isA (n' `elem`)
                  )
              none
              (this >>> perform (nextState (n':)))

        removeDoubleAttlist :: Attributes -> SLA [String] XmlTree XmlTree
        removeDoubleAttlist al
            = checkName' elemAttr
            where
            elemAttr = elemName ++ "|" ++ attrName
            attrName = dtd_value al
            elemName = dtd_name al

        removeDoubleEntity  :: Attributes -> SLA [String] XmlTree XmlTree
        removeDoubleEntity al
            = checkName' (dtd_name al)

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