content: -- ------------------------------------------------------------
  
  {- |
     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 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.
  
     Before the document is validated, a lookup-table is build on the basis of
     the DTD which maps element names to their validation functions.
     After this initialization phase the whole document is traversed in preorder
     and every element is validated by the XmlFilter from the lookup-table.
  
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.DTDValidation.DocValidation
      ( validateDoc
      )
  where
  
  import Text.XML.HXT.DTDValidation.TypeDefs
  
  import Text.XML.HXT.DTDValidation.AttributeValueValidation
  import Text.XML.HXT.DTDValidation.XmlRE
  
  -- ------------------------------------------------------------
  
  -- |
  -- Lookup-table which maps element names to their validation functions. The
  -- validation functions are XmlArrows.
  
  type ValiEnvTable       = [ValiEnv]
  type ValiEnv            = (ElemName, ValFct)
  type ElemName           = String
  type ValFct             = XmlArrow
  
  
  -- ------------------------------------------------------------
  
  -- |
  -- Validate a document.
  --
  --    * 1.parameter dtdPart :  the DTD subset (Node @DOCTYPE@) of the XmlTree
  --
  --    - 2.parameter doc :  the document subset of the XmlTree
  --
  --    - returns : a list of errors
  
  validateDoc     :: XmlTree -> XmlArrow
  validateDoc dtdPart
      = traverseTree valTable
      where
      valTable = buildAllValidationFunctions dtdPart
  
  
  -- |
  -- Traverse the XmlTree in preorder.
  --
  --    * 1.parameter valiEnv :  lookup-table which maps element names to their validation functions
  --
  --    - returns : list of errors
  
  traverseTree    :: ValiEnvTable -> XmlArrow
  traverseTree valiEnv
      = choiceA [ isElem  :-> (valFct $< getQName)
                , this    :-> none
                ]
        <+>
        ( getChildren >>> traverseTree valiEnv )
      where
      valFct      :: QName -> XmlArrow
      valFct name = case (lookup (qualifiedName name) valiEnv) of
                    Nothing -> err ("Element " ++ show (qualifiedName name) ++ " not declared in DTD.")
                    Just f  -> f
  
  -- ------------------------------------------------------------
  
  -- |
  -- Build all validation functions.
  --
  --    * 1.parameter dtdPart :  DTD subset, root node should be of type @DOCTYPE@
  --
  --    - returns : lookup-table which maps element names to their validation functions
  
  buildAllValidationFunctions :: XmlTree -> ValiEnvTable
  buildAllValidationFunctions dtdPart
      = concat $
        buildValidateRoot dtdPart :             -- construct a list of validation filters for all element declarations
        map (buildValidateFunctions dtdNodes) dtdNodes
        where
        dtdNodes = runLA getChildren dtdPart
  
  -- |
  -- Build a validation function for the document root. By root node @\/@
  -- is meant, which is the topmost dummy created by the parser.
  --
  --    * 1.parameter dtdPart :  DTD subset, root node should be of type @DOCTYPE@
  --
  --    - returns : entry for the lookup-table
  
  buildValidateRoot :: XmlTree -> [ValiEnv]
  buildValidateRoot dn
      | isDTDDoctypeNode dn       = [(t_root, valFct)]
      | otherwise                 = []
        where
        name      = dtd_name . getDTDAttributes $ dn
  
        valFct    :: XmlArrow
        valFct    = isElem
                    `guards`
                    ( checkRegex (re_sym name)
                      >>>
                      msgToErr (("Root Element must be " ++ show name ++ ". ") ++)
                    )
  
  checkRegex      :: RE String -> LA XmlTree String
  checkRegex re   = listA getChildren
                    >>> arr (\ cs -> checkRE (matches re cs))
  
  -- |
  -- Build validation functions for an element.
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter nd :  element declaration for which the validation functions are
  --                   created
  --
  --    - returns : entry for the lookup-table
  
  buildValidateFunctions :: XmlTrees -> XmlTree -> [ValiEnv]
  
  buildValidateFunctions dtdPart dn
      | isDTDElementNode dn       = [(elemName, valFct)]
      | otherwise                 = []
        where
        elemName = dtd_name . getDTDAttributes $ dn
  
        valFct :: XmlArrow
        valFct = buildContentValidation dn
                 <+>
                 buildAttributeValidation dtdPart dn
  
  -- ------------------------------------------------------------
  
  
  -- |
  -- Build validation functions for the content model of an element.
  -- Validity constraint: Element Valid (3 \/ p.18 in Spec)
  --
  --    * 1.parameter nd :  element declaration for which the content validation functions
  --                  are built
  --
  --    - returns : a function which takes an element (XTag), checks if its
  --                  children match its content model and returns a list of errors
  
  buildContentValidation :: XmlTree -> XmlArrow
  buildContentValidation nd
      = contentValidation attrType nd
        where
        attrType = dtd_type . getDTDAttributes $ nd
  
  
        -- Delegates construction of the validation function on the basis of the
        -- content model type
        contentValidation :: String -> XmlTree -> XmlArrow
        contentValidation typ dn
            | typ == k_pcdata   = contentValidationPcdata
            | typ == k_empty    = contentValidationEmpty
            | typ == k_any      = contentValidationAny
            | typ == v_children = contentValidationChildren cs
            | typ == v_mixed    = contentValidationMixed cs
            | otherwise         = none
            where
            cs = runLA getChildren dn
  
        -- Checks #PCDATA content models
        contentValidationPcdata :: XmlArrow
        contentValidationPcdata
            = isElem `guards` (contentVal $< getQName)
              where
              contentVal name
                  = checkRegex (re_rep (re_sym k_pcdata))
                    >>>
                    msgToErr ( ( "The content of element " ++
                                 show (qualifiedName name) ++
                                 " must match (#PCDATA). "
                               ) ++
                             )
  
        -- Checks EMPTY content models
        contentValidationEmpty :: XmlArrow
        contentValidationEmpty
            = isElem `guards` (contentVal $< getQName)
              where
              contentVal name
                  = checkRegex re_unit
                    >>>
                    msgToErr ( ( "The content of element " ++
                                   show (qualifiedName name) ++
                                   " must match EMPTY. "
                               ) ++
                             )
  
        -- Checks ANY content models
        contentValidationAny :: XmlArrow
        contentValidationAny
            = isElem `guards` (contentVal $< getName)
              where
              contentVal name
                  = checkRegex (re_rep (re_dot))
                    >>>
                    msgToErr ( ( "The content of element " ++
                                 show name ++
                                 " must match ANY. "
                               ) ++
                             )
  
        -- Checks "children" content models
        contentValidationChildren :: XmlTrees -> XmlArrow
        contentValidationChildren cm
            = isElem `guards` (contentVal $< getName)
              where
              contentVal name
                  = checkRegex re
                    >>>
                    msgToErr ( ( "The content of element " ++
                                 show name ++
                                 " must match " ++ printRE re ++ ". "
                               ) ++
                             )
              re = createRE (head cm)
  
        -- Checks "mixed content" content models
        contentValidationMixed :: XmlTrees -> XmlArrow
        contentValidationMixed cm
            = isElem `guards` (contentVal $< getName)
              where
              contentVal name
                  = checkRegex re
                    >>>
                    msgToErr ( ( "The content of element " ++
                                 show name ++
                                 " must match " ++ printRE re ++ ". "
                               ) ++
                             )
              re = re_rep (re_alt (re_sym k_pcdata) (createRE (head cm)))
  
  -- |
  -- Build a regular expression from the content model. The regular expression
  -- is provided by the module XmlRE.
  --
  --    * 1.parameter nd :  node of the content model. Expected: @CONTENT@ or
  --              @NAME@
  --
  --    - returns : regular expression of the content model
  
  createRE        ::  XmlTree -> RE String
  createRE dn
      | isDTDContentNode dn
          = processModifier modifier
      | isDTDNameNode dn
          = re_sym name
      | otherwise
          = error ("createRE: illegeal parameter:\n" ++ show dn)
      where
      al          = getDTDAttributes dn
      name        = dtd_name     al
      modifier    = dtd_modifier al
      kind        = dtd_kind     al
      cs          = runLA getChildren dn
  
      processModifier :: String -> RE String
      processModifier m
          | m == v_plus     = re_plus (processKind kind)
          | m == v_star     = re_rep  (processKind kind)
          | m == v_option   = re_opt  (processKind kind)
          | m == v_null     = processKind kind
          | otherwise       = error ("Unknown modifier: " ++ show m)
  
      processKind :: String -> RE String
      processKind k
          | k == v_seq      = makeSequence cs
          | k == v_choice   = makeChoice cs
          | otherwise       = error ("Unknown kind: " ++ show k)
  
      makeSequence :: XmlTrees -> RE String
      makeSequence []     = re_unit
      makeSequence (x:xs) = re_seq (createRE x) (makeSequence xs)
  
      makeChoice :: XmlTrees -> RE String
      makeChoice []       = re_zero ""
      makeChoice (x:xs)   = re_alt (createRE x) (makeChoice xs)
  
  -- ------------------------------------------------------------
  
  -- |
  -- Build validation functions for the attributes of an element.
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter nd :  element declaration for which the attribute validation functions
  --                  are created
  --
  --    - returns : a function which takes an element (XTag), checks if its
  --                  attributes are valid and returns a list of errors
  
  buildAttributeValidation :: XmlTrees -> XmlTree -> XmlArrow
  buildAttributeValidation dtdPart nd =
      noDoublicateAttributes
      <+>
      checkNotDeclardAttributes attrDecls nd
      <+>
      checkRequiredAttributes attrDecls nd
      <+>
      checkFixedAttributes attrDecls nd
      <+>
      checkValuesOfAttributes attrDecls dtdPart nd
      where
      attrDecls = isDTDAttlist $$ dtdPart
  
  
  -- |
  -- Validate that all attributes of an element are unique.
  -- Well-formdness constraint: Unique AttSpec (3.1 \/ p.19 in Spec)
  --
  --    - returns : a function which takes an element (XTag), checks if its
  --                  attributes are unique and returns a list of errors
  
  noDoublicateAttributes  :: XmlArrow
  noDoublicateAttributes
      = isElem
        `guards`
        ( noDoubles' $< getName )
      where
      noDoubles' elemName
          = listA (getAttrl >>> getName)
            >>> applyA (arr (catA . map toErr . doubles . reverse))
          where
          toErr n1 = err ( "Attribute " ++ show n1 ++
                           " was already specified for element " ++
                           show elemName ++ "."
                         )
  
  -- |
  -- Validate that all \#REQUIRED attributes are provided.
  -- Validity constraint: Required Attributes (3.3.2 \/ p.28 in Spec)
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter nd :  element declaration which attributes have to be checked
  --
  --    - returns : a function which takes an element (XTag), checks if all
  --                  required attributes are provided and returns a list of errors
  
  checkRequiredAttributes :: XmlTrees -> XmlTree -> XmlArrow
  checkRequiredAttributes attrDecls dn
      | isDTDElementNode dn
          = isElem
            `guards`
            ( checkRequired $< getName )
      | otherwise
          = none
        where
        elemName     = dtd_name . getDTDAttributes $ dn
        requiredAtts = (isAttlistOfElement elemName >>> isRequiredAttrKind) $$ attrDecls
  
        checkRequired :: String -> XmlArrow
        checkRequired name
            = catA . map checkReq $ requiredAtts
            where
            checkReq      :: XmlTree -> XmlArrow
            checkReq attrDecl
                = neg (hasAttr attName)
                  `guards`
                  err ( "Attribute " ++ show attName ++ " must be declared for element type " ++
                        show name ++ "." )
                where
                attName = dtd_value . getDTDAttributes $ attrDecl
  
  -- |
  -- Validate that \#FIXED attributes match the default value.
  -- Validity constraint: Fixed Attribute Default (3.3.2 \/ p.28 in Spec)
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter nd :  element declaration which attributes have to be checked
  --
  --    - returns : a function which takes an element (XTag), checks if all
  --                  fixed attributes match the default value and returns a list of errors
  
  checkFixedAttributes :: XmlTrees -> XmlTree -> XmlArrow
  checkFixedAttributes attrDecls dn
      | isDTDElementNode dn
          = isElem
            `guards`
            ( checkFixed $< getName )
      | otherwise
          = none
        where
        elemName  = dtd_name . getDTDAttributes $ dn
        fixedAtts = (isAttlistOfElement elemName >>> isFixedAttrKind) $$ attrDecls
  
        checkFixed :: String -> XmlArrow
        checkFixed name
            = catA . map checkFix $ fixedAtts
            where
            checkFix      :: XmlTree -> XmlArrow
            checkFix an
                |  isDTDAttlistNode an
                    = checkFixedVal $< getAttrValue attName
                | otherwise
                    = none
                where
                al'       = getDTDAttributes an
                attName   = dtd_value   al'
                defa      = dtd_default al'
                fixedValue = normalizeAttributeValue (Just an) defa
  
                checkFixedVal     :: String -> XmlArrow
                checkFixedVal val
                    = ( ( hasAttr attName
                          >>>
                          isA (const (attValue /= fixedValue))
                        )
                        `guards`
                        err ( "Attribute " ++ show attName ++ " of element " ++ show name ++
                              " with value " ++ show attValue ++ " must have a value of " ++
                              show fixedValue ++ "." )
                      )
                    where
                    attValue   = normalizeAttributeValue (Just an) val
  
  -- |
  -- Validate that an element has no attributes which are not declared.
  -- Validity constraint: Attribute Value Type (3.1 \/ p.19 in Spec)
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter nd :  element declaration which attributes have to be checked
  --
  --    - returns : a function which takes an element (XTag), checks if all
  --                  attributes are declared and returns a list of errors
  
  checkNotDeclardAttributes :: XmlTrees -> XmlTree -> XmlArrow
  checkNotDeclardAttributes attrDecls elemDescr
      = checkNotDeclared
        where
        elemName = valueOfDTD a_name elemDescr
        decls    = isAttlistOfElement elemName $$ attrDecls
  
        checkNotDeclared :: XmlArrow
        checkNotDeclared
            = isElem
              `guards`
              ( getAttrl >>> searchForDeclaredAtt elemName decls )
  
        searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
        searchForDeclaredAtt name (dn : xs)
            | isDTDAttlistNode dn
                = ( getName >>> isA ( (dtd_value . getDTDAttributes $ dn) /= ) )
                  `guards`
                  searchForDeclaredAtt name xs
            | otherwise
                = searchForDeclaredAtt name xs
  
        searchForDeclaredAtt name []
            = mkErr $< getName
              where
              mkErr n = err ( "Attribute " ++ show n ++ " of element " ++
                              show name ++ " is not declared in DTD." )
  
  -- |
  -- Validate that the attribute value meets the lexical constraints of its type.
  -- Validity constaint: Attribute Value Type (3.1 \/ p.19 in Spec)
  --
  --    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
  --
  --    - 2.parameter nd :  element declaration which attributes have to be checked
  --
  --    - returns : a function which takes an element (XTag), checks if all
  --                  attributes meet the lexical constraints and returns a list of errors
  
  checkValuesOfAttributes :: XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
  checkValuesOfAttributes attrDecls dtdPart elemDescr
      = checkValues
        where
        elemName  = dtd_name . getDTDAttributes $ elemDescr
        decls     = isAttlistOfElement elemName $$ attrDecls
  
        checkValues :: XmlArrow
        checkValues
            = isElem
              `guards`
              ( checkValue $< getAttrl )
  
        checkValue att
            = catA . map checkVal $ decls
              where
              checkVal :: XmlTree -> XmlArrow
              checkVal attrDecl
                  | isDTDAttlistNode attrDecl
                    &&
                    nameOfAttr att == dtd_value al'
                        = checkAttributeValue dtdPart attrDecl
                  | otherwise
                      = none
                  where
                  al' = getDTDAttributes attrDecl
  
  -- ------------------------------------------------------------
  