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

{- |
   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
    = [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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem  XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> (QName -> XmlArrow
valFct (QName -> XmlArrow) -> LA XmlTree QName -> XmlArrow
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
              , 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
              ]
      XmlArrow -> XmlArrow -> XmlArrow
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
      ( 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
>>> ValiEnvTable -> XmlArrow
traverseTree ValiEnvTable
valiEnv )
    where
    valFct      :: QName -> XmlArrow
    valFct :: QName -> XmlArrow
valFct QName
name = case (String -> ValiEnvTable -> Maybe XmlArrow
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (QName -> String
qualifiedName QName
name) ValiEnvTable
valiEnv) of
                  Maybe XmlArrow
Nothing -> String -> XmlArrow
forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
err (String
"Element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) String -> String -> String
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
    = [ValiEnvTable] -> ValiEnvTable
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([ValiEnvTable] -> ValiEnvTable) -> [ValiEnvTable] -> ValiEnvTable
forall a b. (a -> b) -> a -> b
$
      XmlTree -> ValiEnvTable
buildValidateRoot XmlTree
dtdPart ValiEnvTable -> [ValiEnvTable] -> [ValiEnvTable]
forall a. a -> [a] -> [a]
:             -- construct a list of validation filters for all element declarations
      (XmlTree -> ValiEnvTable) -> [XmlTree] -> [ValiEnvTable]
forall a b. (a -> b) -> [a] -> [b]
map ([XmlTree] -> XmlTree -> ValiEnvTable
buildValidateFunctions [XmlTree]
dtdNodes) [XmlTree]
dtdNodes
      where
      dtdNodes :: [XmlTree]
dtdNodes = XmlArrow -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
runLA XmlArrow
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 (Attributes -> String)
-> (XmlTree -> Attributes) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes (XmlTree -> String) -> XmlTree -> String
forall a b. (a -> b) -> a -> b
$ XmlTree
dn

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

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

      valFct :: XmlArrow
      valFct :: XmlArrow
valFct = XmlTree -> XmlArrow
buildContentValidation XmlTree
dn
               XmlArrow -> XmlArrow -> XmlArrow
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+>
               [XmlTree] -> XmlTree -> XmlArrow
buildAttributeValidation [XmlTree]
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 (Attributes -> String)
-> (XmlTree -> Attributes) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes (XmlTree -> String) -> XmlTree -> String
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_pcdata   = XmlArrow
contentValidationPcdata
          | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_empty    = XmlArrow
contentValidationEmpty
          | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_any      = XmlArrow
contentValidationAny
          | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_children = [XmlTree] -> XmlArrow
contentValidationChildren [XmlTree]
cs
          | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_mixed    = [XmlTree] -> XmlArrow
contentValidationMixed [XmlTree]
cs
          | Bool
otherwise         = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          where
          cs :: [XmlTree]
cs = XmlArrow -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
runLA XmlArrow
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
          = XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem XmlArrow -> XmlArrow -> XmlArrow
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (QName -> XmlArrow
contentVal (QName -> XmlArrow) -> LA XmlTree QName -> XmlArrow
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree QName
forall (a :: * -> * -> *). ArrowXml a => a XmlTree QName
getQName)
            where
            contentVal :: QName -> XmlArrow
contentVal QName
name
                = RE String -> LA XmlTree String
checkRegex (RE String -> RE String
forall a. RE a -> RE a
re_rep (String -> RE String
forall a. a -> RE a
re_sym String
k_pcdata))
                  LA XmlTree String -> LA String 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 String XmlTree
msgToErr ( ( String
"The content of element " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               String -> String
forall a. Show a => a -> String
show (QName -> String
qualifiedName QName
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               String
" must match (#PCDATA). "
                             ) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           )

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

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

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

      -- Checks "mixed content" content models
      contentValidationMixed :: XmlTrees -> XmlArrow
      contentValidationMixed :: [XmlTree] -> XmlArrow
contentValidationMixed [XmlTree]
cm
          = XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem XmlArrow -> XmlArrow -> XmlArrow
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards` (String -> XmlArrow
forall a. Show a => a -> XmlArrow
contentVal (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName)
            where
            contentVal :: a -> XmlArrow
contentVal a
name
                = RE String -> LA XmlTree String
checkRegex RE String
re
                  LA XmlTree String -> LA String 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 String XmlTree
msgToErr ( ( String
"The content of element " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               a -> String
forall a. Show a => a -> String
show a
name String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               String
" must match " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RE String -> String
forall a. (Eq a, Show a) => RE a -> String
printRE RE String
re String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". "
                             ) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           )
            re :: RE String
re = RE String -> RE String
forall a. RE a -> RE a
re_rep (RE String -> RE String -> RE String
forall a. Ord a => RE a -> RE a -> RE a
re_alt (String -> RE String
forall a. a -> RE a
re_sym String
k_pcdata) (XmlTree -> RE String
createRE ([XmlTree] -> XmlTree
forall a. [a] -> a
head [XmlTree]
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
        = String -> RE String
forall a. a -> RE a
re_sym String
name
    | Bool
otherwise
        = String -> RE String
forall a. HasCallStack => String -> a
error (String
"createRE: illegeal parameter:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ XmlTree -> String
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 :: [XmlTree]
cs          = XmlArrow -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
runLA XmlArrow
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_plus     = RE String -> RE String
forall a. RE a -> RE a
re_plus (String -> RE String
processKind String
kind)
        | String
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_star     = RE String -> RE String
forall a. RE a -> RE a
re_rep  (String -> RE String
processKind String
kind)
        | String
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_option   = RE String -> RE String
forall a. Ord a => RE a -> RE a
re_opt  (String -> RE String
processKind String
kind)
        | String
m String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_null     = String -> RE String
processKind String
kind
        | Bool
otherwise       = String -> RE String
forall a. HasCallStack => String -> a
error (String
"Unknown modifier: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
m)

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

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

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

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

      checkFixed :: String -> XmlArrow
      checkFixed :: String -> XmlArrow
checkFixed String
name
          = [XmlArrow] -> XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> ([XmlTree] -> [XmlArrow]) -> [XmlTree] -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XmlTree -> XmlArrow) -> [XmlTree] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map XmlTree -> XmlArrow
checkFix ([XmlTree] -> XmlArrow) -> [XmlTree] -> XmlArrow
forall a b. (a -> b) -> a -> b
$ [XmlTree]
fixedAtts
          where
          checkFix      :: XmlTree -> XmlArrow
          checkFix :: XmlTree -> XmlArrow
checkFix XmlTree
an
              |  XmlTree -> Bool
isDTDAttlistNode XmlTree
an
                  = String -> XmlArrow
checkFixedVal (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< String -> LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
attName
              | Bool
otherwise
                  = XmlArrow
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 (XmlTree -> Maybe XmlTree
forall a. a -> Maybe a
Just XmlTree
an) String
defa

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

      checkNotDeclared :: XmlArrow
      checkNotDeclared :: XmlArrow
checkNotDeclared
          = XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
            XmlArrow -> XmlArrow -> XmlArrow
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
            ( XmlArrow
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
getAttrl 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 -> [XmlTree] -> XmlArrow
searchForDeclaredAtt String
elemName [XmlTree]
decls )

      searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow
      searchForDeclaredAtt :: String -> [XmlTree] -> XmlArrow
searchForDeclaredAtt String
name (XmlTree
dn : [XmlTree]
xs)
          | XmlTree -> Bool
isDTDAttlistNode XmlTree
dn
              = ( LA XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getName LA XmlTree String -> LA String 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 -> Bool) -> LA String String
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA ( (Attributes -> String
dtd_value (Attributes -> String)
-> (XmlTree -> Attributes) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes (XmlTree -> String) -> XmlTree -> String
forall a b. (a -> b) -> a -> b
$ XmlTree
dn) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ) )
                LA XmlTree String -> XmlArrow -> XmlArrow
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d
`guards`
                String -> [XmlTree] -> XmlArrow
searchForDeclaredAtt String
name [XmlTree]
xs
          | Bool
otherwise
              = String -> [XmlTree] -> XmlArrow
searchForDeclaredAtt String
name [XmlTree]
xs

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

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

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

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