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

    {- |
       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 dtdPart :: 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 valiEnv :: 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 name :: 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
                      Nothing -> String -> XmlArrow
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ("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]
    ++ " not declared in DTD.")
                      Just f :: 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 dtdPart :: 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 dn :: 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 (("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
    forall a. [a] -> [a] -> [a]
    ++)
                      )

    checkRegex      :: RE String -> LA XmlTree String
    checkRegex :: RE String -> LA XmlTree String
    checkRegex re :: 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 (\ cs :: [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 dtdPart :: [XmlTree]
    dtdPart dn :: 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 nd :: 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 typ :: String
    typ dn :: 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 name :: 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 ( ( "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]
    ++
                                   " 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 name :: 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 ( ( "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]
    ++
                                     " 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 name :: 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 ( ( "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]
    ++
                                   " must match ANY. "
                                 ) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                               )

          -- Checks "children" content models
          contentValidationChildren :: XmlTrees -> XmlArrow
          contentValidationChildren :: [XmlTree] -> XmlArrow
    contentValidationChildren cm :: [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 name :: 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 ( ( "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]
    ++
                                   " 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
    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 cm :: [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 name :: 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 ( ( "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]
    ++
                                   " 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
    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 dn :: 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 ("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 m :: 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 ("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 k :: 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 ("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 (x :: XmlTree
    x:xs :: [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 ""
        makeChoice (x :: XmlTree
    x:xs :: [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 dtdPart :: [XmlTree]
    dtdPart nd :: 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' elemName :: 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 n1 :: a
    n1 = String -> a n XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "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]
    ++
                             " 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]
    ++ "."
                           )

    -- |
    -- 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 attrDecls :: [XmlTree]
    attrDecls dn :: 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 name :: 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 attrDecl :: 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 ( "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]
    ++ " 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]
    ++ "." )
                  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 attrDecls :: [XmlTree]
    attrDecls dn :: 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 name :: 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 an :: 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 val :: 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 ( "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]
    ++ " 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]
    ++
                                " 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]
    ++ " 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]
    ++ "." )
                        )
                      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 attrDecls :: [XmlTree]
    attrDecls elemDescr :: 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 name :: String
    name (dn :: XmlTree
    dn : xs :: [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 name :: 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 n :: a
    n = String -> a n XmlTree
    forall (a :: * -> * -> *) n. ArrowXml a => String -> a n XmlTree
    err ( "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]
    ++ " 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]
    ++ " 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 attrDecls :: [XmlTree]
    attrDecls dtdPart :: [XmlTree]
    dtdPart elemDescr :: 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 att :: 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 attrDecl :: 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

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