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

{- |
   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 :: XmlTree -> XmlArrow
validateDoc XmlTree
dtdPart
    = ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valTable
    where
    valTable :: ValiEnvTable
valTable = XmlTree -> ValiEnvTable
buildAllValidationFunctions XmlTree
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 :: ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valiEnv
    = forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA [ forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem  forall a b. a -> b -> IfThen a b
:-> (QName -> XmlArrow
valFct forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
              , forall (a :: * -> * -> *) b. ArrowList a => a b b
this    forall a b. a -> b -> IfThen a b
:-> forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
              ]
      forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      ( forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valiEnv )
    where
    valFct      :: QName -> XmlArrow
    valFct :: QName -> XmlArrow
valFct QName
name = case (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (QName -> String
qualifiedName QName
name) ValiEnvTable
valiEnv) of
                  Maybe XmlArrow
Nothing -> forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err (String
"Element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) forall a. [a] -> [a] -> [a]
++ String
" not declared in DTD.")
                  Just XmlArrow
f  -> XmlArrow
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 :: XmlTree -> ValiEnvTable
buildAllValidationFunctions XmlTree
dtdPart
    = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
      XmlTree -> ValiEnvTable
buildValidateRoot XmlTree
dtdPart forall a. a -> [a] -> [a]
:             -- construct a list of validation filters for all element declarations
      forall a b. (a -> b) -> [a] -> [b]
map (XmlTrees -> XmlTree -> ValiEnvTable
buildValidateFunctions XmlTrees
dtdNodes) XmlTrees
dtdNodes
      where
      dtdNodes :: XmlTrees
dtdNodes = forall a b. LA a b -> a -> [b]
runLA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlTree
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 :: XmlTree -> ValiEnvTable
buildValidateRoot XmlTree
dn
    | XmlTree -> Bool
isDTDDoctypeNode XmlTree
dn       = [(String
t_root, XmlArrow
valFct)]
    | Bool
otherwise                 = []
      where
      name :: String
name      = Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn

      valFct    :: XmlArrow
      valFct :: XmlArrow
valFct    = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
                  forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                  ( RE String -> LA XmlTree String
checkRegex (forall a. a -> RE a
re_sym String
name)
                    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 String XmlTree
msgToErr ((String
"Root Element must be " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
". ") forall a. [a] -> [a] -> [a]
++)
                  )

checkRegex      :: RE String -> LA XmlTree String
checkRegex :: RE String -> LA XmlTree String
checkRegex RE String
re   = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren
                  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ XmlTrees
cs -> forall a. (Eq a, Show a) => RE a -> String
checkRE (RE String -> XmlTrees -> RE String
matches RE String
re XmlTrees
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 :: XmlTrees -> XmlTree -> ValiEnvTable
buildValidateFunctions XmlTrees
dtdPart XmlTree
dn
    | XmlTree -> Bool
isDTDElementNode XmlTree
dn       = [(String
elemName, XmlArrow
valFct)]
    | Bool
otherwise                 = []
      where
      elemName :: String
elemName = Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn

      valFct :: XmlArrow
      valFct :: XmlArrow
valFct = XmlTree -> XmlArrow
buildContentValidation XmlTree
dn
               forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
               XmlTrees -> XmlTree -> XmlArrow
buildAttributeValidation XmlTrees
dtdPart XmlTree
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 :: XmlTree -> XmlArrow
buildContentValidation XmlTree
nd
    = String -> XmlTree -> XmlArrow
contentValidation String
attrType XmlTree
nd
      where
      attrType :: String
attrType = Attributes -> String
dtd_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
nd


      -- Delegates construction of the validation function on the basis of the
      -- content model type
      contentValidation :: String -> XmlTree -> XmlArrow
      contentValidation :: String -> XmlTree -> XmlArrow
contentValidation String
typ XmlTree
dn
          | String
typ forall a. Eq a => a -> a -> Bool
== String
k_pcdata   = XmlArrow
contentValidationPcdata
          | String
typ forall a. Eq a => a -> a -> Bool
== String
k_empty    = XmlArrow
contentValidationEmpty
          | String
typ forall a. Eq a => a -> a -> Bool
== String
k_any      = XmlArrow
contentValidationAny
          | String
typ forall a. Eq a => a -> a -> Bool
== String
v_children = XmlTrees -> XmlArrow
contentValidationChildren XmlTrees
cs
          | String
typ forall a. Eq a => a -> a -> Bool
== String
v_mixed    = XmlTrees -> XmlArrow
contentValidationMixed XmlTrees
cs
          | Bool
otherwise         = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          where
          cs :: XmlTrees
cs = forall a b. LA a b -> a -> [b]
runLA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlTree
dn

      -- Checks #PCDATA content models
      contentValidationPcdata :: XmlArrow
      contentValidationPcdata :: XmlArrow
contentValidationPcdata
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
            where
            contentVal :: QName -> XmlArrow
contentVal QName
name
                = RE String -> LA XmlTree String
checkRegex (forall a. RE a -> RE a
re_rep (forall a. a -> RE a
re_sym String
k_pcdata))
                  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 String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
                               forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) forall a. [a] -> [a] -> [a]
++
                               String
" must match (#PCDATA). "
                             ) forall a. [a] -> [a] -> [a]
++
                           )

      -- Checks EMPTY content models
      contentValidationEmpty :: XmlArrow
      contentValidationEmpty :: XmlArrow
contentValidationEmpty
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
            where
            contentVal :: QName -> XmlArrow
contentVal QName
name
                = RE String -> LA XmlTree String
checkRegex forall a. RE a
re_unit
                  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 String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
                                 forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) forall a. [a] -> [a] -> [a]
++
                                 String
" must match EMPTY. "
                             ) forall a. [a] -> [a] -> [a]
++
                           )

      -- Checks ANY content models
      contentValidationAny :: XmlArrow
      contentValidationAny :: XmlArrow
contentValidationAny
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (forall {a}. Show a => a -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
            where
            contentVal :: a -> XmlArrow
contentVal a
name
                = RE String -> LA XmlTree String
checkRegex (forall a. RE a -> RE a
re_rep (forall a. RE a
re_dot))
                  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 String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
                               forall a. Show a => a -> String
show a
name forall a. [a] -> [a] -> [a]
++
                               String
" must match ANY. "
                             ) forall a. [a] -> [a] -> [a]
++
                           )

      -- Checks "children" content models
      contentValidationChildren :: XmlTrees -> XmlArrow
      contentValidationChildren :: XmlTrees -> XmlArrow
contentValidationChildren XmlTrees
cm
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (forall {a}. Show a => a -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
            where
            contentVal :: a -> XmlArrow
contentVal a
name
                = RE String -> LA XmlTree String
checkRegex RE String
re
                  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 String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
                               forall a. Show a => a -> String
show a
name forall a. [a] -> [a] -> [a]
++
                               String
" must match " forall a. [a] -> [a] -> [a]
++ forall a. (Eq a, Show a) => RE a -> String
printRE RE String
re forall a. [a] -> [a] -> [a]
++ String
". "
                             ) forall a. [a] -> [a] -> [a]
++
                           )
            re :: RE String
re = XmlTree -> RE String
createRE (forall a. [a] -> a
head XmlTrees
cm)

      -- Checks "mixed content" content models
      contentValidationMixed :: XmlTrees -> XmlArrow
      contentValidationMixed :: XmlTrees -> XmlArrow
contentValidationMixed XmlTrees
cm
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (forall {a}. Show a => a -> XmlArrow
contentVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
            where
            contentVal :: a -> XmlArrow
contentVal a
name
                = RE String -> LA XmlTree String
checkRegex RE String
re
                  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 String XmlTree
msgToErr ( ( String
"The content of element " forall a. [a] -> [a] -> [a]
++
                               forall a. Show a => a -> String
show a
name forall a. [a] -> [a] -> [a]
++
                               String
" must match " forall a. [a] -> [a] -> [a]
++ forall a. (Eq a, Show a) => RE a -> String
printRE RE String
re forall a. [a] -> [a] -> [a]
++ String
". "
                             ) forall a. [a] -> [a] -> [a]
++
                           )
            re :: RE String
re = forall a. RE a -> RE a
re_rep (forall a. Ord a => RE a -> RE a -> RE a
re_alt (forall a. a -> RE a
re_sym String
k_pcdata) (XmlTree -> RE String
createRE (forall a. [a] -> a
head XmlTrees
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 :: XmlTree -> RE String
createRE XmlTree
dn
    | XmlTree -> Bool
isDTDContentNode XmlTree
dn
        = String -> RE String
processModifier String
modifier
    | XmlTree -> Bool
isDTDNameNode XmlTree
dn
        = forall a. a -> RE a
re_sym String
name
    | Bool
otherwise
        = forall a. HasCallStack => String -> a
error (String
"createRE: illegeal parameter:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show XmlTree
dn)
    where
    al :: Attributes
al          = XmlTree -> Attributes
getDTDAttributes XmlTree
dn
    name :: String
name        = Attributes -> String
dtd_name     Attributes
al
    modifier :: String
modifier    = Attributes -> String
dtd_modifier Attributes
al
    kind :: String
kind        = Attributes -> String
dtd_kind     Attributes
al
    cs :: XmlTrees
cs          = forall a b. LA a b -> a -> [b]
runLA forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren XmlTree
dn

    processModifier :: String -> RE String
    processModifier :: String -> RE String
processModifier String
m
        | String
m forall a. Eq a => a -> a -> Bool
== String
v_plus     = forall a. RE a -> RE a
re_plus (String -> RE String
processKind String
kind)
        | String
m forall a. Eq a => a -> a -> Bool
== String
v_star     = forall a. RE a -> RE a
re_rep  (String -> RE String
processKind String
kind)
        | String
m forall a. Eq a => a -> a -> Bool
== String
v_option   = forall a. Ord a => RE a -> RE a
re_opt  (String -> RE String
processKind String
kind)
        | String
m forall a. Eq a => a -> a -> Bool
== String
v_null     = String -> RE String
processKind String
kind
        | Bool
otherwise       = forall a. HasCallStack => String -> a
error (String
"Unknown modifier: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
m)

    processKind :: String -> RE String
    processKind :: String -> RE String
processKind String
k
        | String
k forall a. Eq a => a -> a -> Bool
== String
v_seq      = XmlTrees -> RE String
makeSequence XmlTrees
cs
        | String
k forall a. Eq a => a -> a -> Bool
== String
v_choice   = XmlTrees -> RE String
makeChoice XmlTrees
cs
        | Bool
otherwise       = forall a. HasCallStack => String -> a
error (String
"Unknown kind: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
k)

    makeSequence :: XmlTrees -> RE String
    makeSequence :: XmlTrees -> RE String
makeSequence []     = forall a. RE a
re_unit
    makeSequence (XmlTree
x:XmlTrees
xs) = forall a. RE a -> RE a -> RE a
re_seq (XmlTree -> RE String
createRE XmlTree
x) (XmlTrees -> RE String
makeSequence XmlTrees
xs)

    makeChoice :: XmlTrees -> RE String
    makeChoice :: XmlTrees -> RE String
makeChoice []       = forall a. String -> RE a
re_zero String
""
    makeChoice (XmlTree
x:XmlTrees
xs)   = forall a. Ord a => RE a -> RE a -> RE a
re_alt (XmlTree -> RE String
createRE XmlTree
x) (XmlTrees -> RE String
makeChoice XmlTrees
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 :: XmlTrees -> XmlTree -> XmlArrow
buildAttributeValidation XmlTrees
dtdPart XmlTree
nd =
    XmlArrow
noDoublicateAttributes
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
    XmlTrees -> XmlTree -> XmlArrow
checkNotDeclardAttributes XmlTrees
attrDecls XmlTree
nd
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
    XmlTrees -> XmlTree -> XmlArrow
checkRequiredAttributes XmlTrees
attrDecls XmlTree
nd
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
    XmlTrees -> XmlTree -> XmlArrow
checkFixedAttributes XmlTrees
attrDecls XmlTree
nd
    forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
    XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
checkValuesOfAttributes XmlTrees
attrDecls XmlTrees
dtdPart XmlTree
nd
    where
    attrDecls :: XmlTrees
attrDecls = forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
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 :: XmlArrow
noDoublicateAttributes
    = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
      forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
      ( forall {cat :: * -> * -> *} {p}.
(ArrowXml cat, Show p) =>
p -> cat XmlTree XmlTree
noDoubles' forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName )
    where
    noDoubles' :: p -> cat XmlTree XmlTree
noDoubles' p
elemName
        = forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
          forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. ArrowList a => a b (a b c) -> a b c
applyA (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a :: * -> * -> *} {a} {n}.
(ArrowXml a, Show a) =>
a -> a n XmlTree
toErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
doubles forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse))
        where
        toErr :: a -> a n XmlTree
toErr a
n1 = forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n1 forall a. [a] -> [a] -> [a]
++
                         String
" was already specified for element " forall a. [a] -> [a] -> [a]
++
                         forall a. Show a => a -> String
show p
elemName forall a. [a] -> [a] -> [a]
++ String
"."
                       )

-- |
-- 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 :: XmlTrees -> XmlTree -> XmlArrow
checkRequiredAttributes XmlTrees
attrDecls XmlTree
dn
    | XmlTree -> Bool
isDTDElementNode XmlTree
dn
        = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
          forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
          ( String -> XmlArrow
checkRequired forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName )
    | Bool
otherwise
        = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      elemName :: String
elemName     = Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn
      requiredAtts :: XmlTrees
requiredAtts = (forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isRequiredAttrKind) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls

      checkRequired :: String -> XmlArrow
      checkRequired :: String -> XmlArrow
checkRequired String
name
          = forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkReq forall a b. (a -> b) -> a -> b
$ XmlTrees
requiredAtts
          where
          checkReq      :: XmlTree -> XmlArrow
          checkReq :: XmlTree -> XmlArrow
checkReq XmlTree
attrDecl
              = forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
neg (forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attName)
                forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attName forall a. [a] -> [a] -> [a]
++ String
" must be declared for element type " forall a. [a] -> [a] -> [a]
++
                      forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
"." )
              where
              attName :: String
attName = Attributes -> String
dtd_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
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 :: XmlTrees -> XmlTree -> XmlArrow
checkFixedAttributes XmlTrees
attrDecls XmlTree
dn
    | XmlTree -> Bool
isDTDElementNode XmlTree
dn
        = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
          forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
          ( String -> XmlArrow
checkFixed forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName )
    | Bool
otherwise
        = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      elemName :: String
elemName  = Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn
      fixedAtts :: XmlTrees
fixedAtts = (forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isFixedAttrKind) XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls

      checkFixed :: String -> XmlArrow
      checkFixed :: String -> XmlArrow
checkFixed String
name
          = forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkFix forall a b. (a -> b) -> a -> b
$ XmlTrees
fixedAtts
          where
          checkFix      :: XmlTree -> XmlArrow
          checkFix :: XmlTree -> XmlArrow
checkFix XmlTree
an
              |  XmlTree -> Bool
isDTDAttlistNode XmlTree
an
                  = String -> XmlArrow
checkFixedVal forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
attName
              | Bool
otherwise
                  = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
              where
              al' :: Attributes
al'       = XmlTree -> Attributes
getDTDAttributes XmlTree
an
              attName :: String
attName   = Attributes -> String
dtd_value   Attributes
al'
              defa :: String
defa      = Attributes -> String
dtd_default Attributes
al'
              fixedValue :: String
fixedValue = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
an) String
defa

              checkFixedVal     :: String -> XmlArrow
              checkFixedVal :: String -> XmlArrow
checkFixedVal String
val
                  = ( ( forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasAttr String
attName
                        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                        forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (forall a b. a -> b -> a
const (String
attValue forall a. Eq a => a -> a -> Bool
/= String
fixedValue))
                      )
                      forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                      forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attName forall a. [a] -> [a] -> [a]
++ String
" of element " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++
                            String
" with value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
attValue forall a. [a] -> [a] -> [a]
++ String
" must have a value of " forall a. [a] -> [a] -> [a]
++
                            forall a. Show a => a -> String
show String
fixedValue forall a. [a] -> [a] -> [a]
++ String
"." )
                    )
                  where
                  attValue :: String
attValue   = Maybe XmlTree -> String -> String
normalizeAttributeValue (forall a. a -> Maybe a
Just XmlTree
an) String
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 :: XmlTrees -> XmlTree -> XmlArrow
checkNotDeclardAttributes XmlTrees
attrDecls XmlTree
elemDescr
    = XmlArrow
checkNotDeclared
      where
      elemName :: String
elemName = String -> XmlTree -> String
valueOfDTD String
a_name XmlTree
elemDescr
      decls :: XmlTrees
decls    = forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls

      checkNotDeclared :: XmlArrow
      checkNotDeclared :: XmlArrow
checkNotDeclared
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
            forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
            ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
elemName XmlTrees
decls )

      searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
      searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
name (XmlTree
dn : XmlTrees
xs)
          | XmlTree -> Bool
isDTDAttlistNode XmlTree
dn
              = ( forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( (Attributes -> String
dtd_value forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
dn) forall a. Eq a => a -> a -> Bool
/= ) )
                forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
name XmlTrees
xs
          | Bool
otherwise
              = String -> XmlTrees -> XmlArrow
searchForDeclaredAtt String
name XmlTrees
xs

      searchForDeclaredAtt String
name []
          = forall {a :: * -> * -> *} {a} {n}.
(ArrowXml a, Show a) =>
a -> a n XmlTree
mkErr forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName
            where
            mkErr :: a -> a n XmlTree
mkErr a
n = forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err ( String
"Attribute " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n forall a. [a] -> [a] -> [a]
++ String
" of element " forall a. [a] -> [a] -> [a]
++
                            forall a. Show a => a -> String
show String
name forall a. [a] -> [a] -> [a]
++ String
" 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 :: XmlTrees -> XmlTrees -> XmlTree -> XmlArrow
checkValuesOfAttributes XmlTrees
attrDecls XmlTrees
dtdPart XmlTree
elemDescr
    = XmlArrow
checkValues
      where
      elemName :: String
elemName  = Attributes -> String
dtd_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes forall a b. (a -> b) -> a -> b
$ XmlTree
elemDescr
      decls :: XmlTrees
decls     = forall (a :: * -> * -> *).
ArrowDTD a =>
String -> a XmlTree XmlTree
isAttlistOfElement String
elemName XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
attrDecls

      checkValues :: XmlArrow
      checkValues :: XmlArrow
checkValues
          = forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
            forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
            ( XmlTree -> XmlArrow
checkValue forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl )

      checkValue :: XmlTree -> XmlArrow
checkValue XmlTree
att
          = forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkVal forall a b. (a -> b) -> a -> b
$ XmlTrees
decls
            where
            checkVal :: XmlTree -> XmlArrow
            checkVal :: XmlTree -> XmlArrow
checkVal XmlTree
attrDecl
                | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
                  Bool -> Bool -> Bool
&&
                  XmlTree -> String
nameOfAttr XmlTree
att forall a. Eq a => a -> a -> Bool
== Attributes -> String
dtd_value Attributes
al'
                      = XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue XmlTrees
dtdPart XmlTree
attrDecl
                | Bool
otherwise
                    = forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
                where
                al' :: Attributes
al' = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl

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