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

{- |
   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 attributes.

   The main functions are:

    - Check if the attribute value meets the lexical constraints of its type

    - Normalization of an attribute value
-}

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

-- Special namings in source code:
--
--  - nd - XDTD node
--
--  - n  - XTag node
--

module Text.XML.HXT.DTDValidation.AttributeValueValidation
    ( checkAttributeValue
    , normalizeAttributeValue
    )
where

import Text.XML.HXT.Parser.XmlParsec
    ( parseNMToken
    , parseName
    )

import Text.XML.HXT.DTDValidation.TypeDefs

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

-- |
-- Checks if the attribute value meets the lexical constraints of its type.
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - returns : a function which takes an element (XTag or XDTD ATTLIST),
--                    checks if the attribute value meets the lexical constraints
--                    of its type and returns a list of errors

checkAttributeValue :: XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue :: XmlTrees -> XmlTree -> XmlArrow
checkAttributeValue XmlTrees
dtdPart XmlTree
attrDecl
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = [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
:-> ( [Char] -> XmlArrow
checkAttrVal ([Char] -> XmlArrow) -> LA XmlTree [Char] -> XmlArrow
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< [Char] -> LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
attrName )
          , XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> ( [Char] -> XmlArrow
checkAttrVal ([Char] -> XmlArrow) -> LA XmlTree [Char] -> XmlArrow
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< (LA XmlTree Attributes
forall (a :: * -> * -> *). ArrowXml a => a XmlTree Attributes
getDTDAttrl LA XmlTree Attributes
-> (Attributes -> [Char]) -> LA XmlTree [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ Attributes -> [Char]
dtd_default) )
          , 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
          ]
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      attrName :: [Char]
attrName  = Attributes -> [Char]
dtd_value Attributes
al
      attrType :: [Char]
attrType  = Attributes -> [Char]
dtd_type  Attributes
al
      checkAttrVal :: [Char] -> XmlArrow
checkAttrVal [Char]
attrValue
          = [Char] -> XmlTrees -> [Char] -> XmlTree -> XmlArrow
checkValue [Char]
attrType XmlTrees
dtdPart [Char]
normalizedVal XmlTree
attrDecl
            where
            normalizedVal :: [Char]
normalizedVal = Maybe XmlTree -> [Char] -> [Char]
normalizeAttributeValue (XmlTree -> Maybe XmlTree
forall a. a -> Maybe a
Just XmlTree
attrDecl) [Char]
attrValue

-- |
-- Dispatches the attibute check by the attribute type.
--
--    * 1.parameter typ :  the attribute type
--
--    - 2.parameter dtdPart :  the children of the @DOCTYPE@ node
--
--    - 3.parameter attrValue :  the normalized attribute value to be checked
--
--    - 4.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - returns : a functions which takes an element (XTag or XDTD ATTLIST),
--                        checks if the attribute value meets the lexical constraints
--                        of its type and returns a list of errors

checkValue :: String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue :: [Char] -> XmlTrees -> [Char] -> XmlTree -> XmlArrow
checkValue [Char]
typ XmlTrees
dtdPart [Char]
attrValue XmlTree
attrDecl
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_cdata        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_enumeration  = XmlTree -> [Char] -> XmlArrow
checkValueEnumeration XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_entity       = XmlTrees -> XmlTree -> [Char] -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_entities     = XmlTrees -> XmlTree -> [Char] -> XmlArrow
checkValueEntities XmlTrees
dtdPart XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_id           = XmlTree -> [Char] -> XmlArrow
checkValueId XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_idref        = XmlTree -> [Char] -> XmlArrow
checkValueIdref XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_idrefs       = XmlTree -> [Char] -> XmlArrow
checkValueIdrefs XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_nmtoken      = XmlTree -> [Char] -> XmlArrow
checkValueNmtoken XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_nmtokens     = XmlTree -> [Char] -> XmlArrow
checkValueNmtokens XmlTree
attrDecl [Char]
attrValue
        | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_notation     = XmlTree -> [Char] -> XmlArrow
checkValueEnumeration XmlTree
attrDecl [Char]
attrValue
        | Bool
otherwise             = [Char] -> XmlArrow
forall a. HasCallStack => [Char] -> a
error ([Char]
"Attribute type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
typ [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" unknown.")

-- |
-- Checks the value of Enumeration attribute types. (3.3.1 \/ p.27 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 2.parameter attrValue :  the normalized attribute value to be checked

checkValueEnumeration :: XmlTree -> String -> XmlArrow
checkValueEnumeration :: XmlTree -> [Char] -> XmlArrow
checkValueEnumeration XmlTree
attrDecl [Char]
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
      Bool -> Bool -> Bool
&&
      [Char]
attrValue [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
enumVals
        = [Char] -> XmlArrow
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Attribute " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_value Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_name Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                [Char]
" must have a value from list "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
enumVals {- ++ " but has value " ++ show attrValue-} [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".")
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl

      enumVals :: [String]
      enumVals :: [[Char]]
enumVals = (XmlTree -> [Char]) -> XmlTrees -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> [Char]
dtd_name (Attributes -> [Char])
-> (XmlTree -> Attributes) -> XmlTree -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes) (XmlTrees -> [[Char]]) -> XmlTrees -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (XmlArrow -> XmlTree -> XmlTrees
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
attrDecl)

-- |
-- Checks the value of ENTITY attribute types. (3.3.1 \/ p.26 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node, to get the
--                    unparsed entity declarations
--
--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 3.parameter attrValue :  the normalized attribute value to be checked

checkValueEntity :: XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity :: XmlTrees -> XmlTree -> [Char] -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl [Char]
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
      Bool -> Bool -> Bool
&&
      [Char]
attrValue [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
upEntities
        = [Char] -> XmlArrow
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Entity " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
attrValue [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of attribute " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_value Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                [Char]
" for element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_name Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not unparsed. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                [Char]
"The following unparsed entities exist: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
upEntities [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".")
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl

      upEntities :: [String]
      upEntities :: [[Char]]
upEntities = (XmlTree -> [Char]) -> XmlTrees -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> [Char]
dtd_name (Attributes -> [Char])
-> (XmlTree -> Attributes) -> XmlTree -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Attributes
getDTDAttributes) (XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isUnparsedEntity XmlArrow -> XmlTrees -> XmlTrees
$$ XmlTrees
dtdPart)

-- |
-- Checks the value of ENTITIES attribute types. (3.3.1 \/ p.26 in Spec)
--
--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node, to get the
--                    unparsed entity declarations
--
--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 3.parameter attrValue :  the normalized attribute value to be checked

checkValueEntities ::XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntities :: XmlTrees -> XmlTree -> [Char] -> XmlArrow
checkValueEntities XmlTrees
dtdPart XmlTree
attrDecl [Char]
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = if [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
valueList
          then [Char] -> XmlArrow
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ([Char]
"Attribute " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_value Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                    [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_name Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" must be one or more names.")
          else [XmlArrow] -> XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> ([[Char]] -> [XmlArrow]) -> [[Char]] -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> XmlArrow) -> [[Char]] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map (XmlTrees -> XmlTree -> [Char] -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl) ([[Char]] -> XmlArrow) -> [[Char]] -> XmlArrow
forall a b. (a -> b) -> a -> b
$ [[Char]]
valueList
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      valueList :: [[Char]]
valueList = [Char] -> [[Char]]
words [Char]
attrValue

-- |
-- Checks the value of NMTOKEN attribute types. (3.3.1 \/ p.26 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 2.parameter attrValue :  the normalized attribute value to be checked

checkValueNmtoken :: XmlTree -> String -> XmlArrow
checkValueNmtoken :: XmlTree -> [Char] -> XmlArrow
checkValueNmtoken XmlTree
attrDecl [Char]
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = [Char] -> LA XmlTree [Char]
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA [Char]
attrValue LA XmlTree [Char] -> LA [Char] XmlTree -> XmlArrow
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA [Char] XmlTree
checkNmtoken
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      checkNmtoken :: LA [Char] XmlTree
checkNmtoken
          = LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText LA [Char] XmlTree -> XmlArrow -> LA [Char] XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (XmlTree -> XmlTrees) -> XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL ([Char] -> XmlTree -> XmlTrees
parseNMToken [Char]
"")
            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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isError
            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
>>>
            LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getErrorMsg
            LA XmlTree [Char] -> LA [Char] XmlTree -> XmlArrow
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ([Char] -> [Char]) -> LA [Char] [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ [Char]
s -> ( [Char]
"Attribute value " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
attrValue [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of attribute " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_value Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
" for element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_name Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" must be a name token, "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [[Char]]
lines [Char]
s) [[Char]] -> Int -> [Char]
forall a. [a] -> Int -> a
!! Int
1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
".") )
            LA [Char] [Char] -> LA [Char] XmlTree -> LA [Char] XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            Int -> LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a [Char] XmlTree
mkError Int
c_err

-- |
-- Checks the value of NMTOKENS attribute types. (3.3.1 \/ p.26 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 2.parameter attrValue :  the normalized attribute value to be checked

checkValueNmtokens :: XmlTree -> String -> XmlArrow
checkValueNmtokens :: XmlTree -> [Char] -> XmlArrow
checkValueNmtokens XmlTree
attrDecl [Char]
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = if [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
valueList
          then [Char] -> XmlArrow
forall (a :: * -> * -> *) n. ArrowXml a => [Char] -> a n XmlTree
err ( [Char]
"Attribute "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_value Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" of element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                     [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_name Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" must be one or more name tokens.")
          else [XmlArrow] -> XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> ([[Char]] -> [XmlArrow]) -> [[Char]] -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> XmlArrow) -> [[Char]] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map (XmlTree -> [Char] -> XmlArrow
checkValueNmtoken XmlTree
attrDecl) ([[Char]] -> XmlArrow) -> [[Char]] -> XmlArrow
forall a b. (a -> b) -> a -> b
$ [[Char]]
valueList
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      valueList :: [[Char]]
valueList = [Char] -> [[Char]]
words [Char]
attrValue

-- |
-- Checks the value of ID attribute types. (3.3.1 \/ p.25 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 2.parameter attrValue :  the normalized attribute value to be checked

checkValueId :: XmlTree -> String -> XmlArrow
checkValueId :: XmlTree -> [Char] -> XmlArrow
checkValueId XmlTree
attrDecl [Char]
attrValue
    = [Char] -> XmlTree -> [Char] -> XmlArrow
checkForName [Char]
"Attribute value" XmlTree
attrDecl [Char]
attrValue


-- |
-- Checks the value of IDREF attribute types. (3.3.1 \/ p.26 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 2.parameter attrValue :  the normalized attribute value to be checked

checkValueIdref :: XmlTree -> String -> XmlArrow
checkValueIdref :: XmlTree -> [Char] -> XmlArrow
checkValueIdref XmlTree
attrDecl [Char]
attrValue
    = [Char] -> XmlTree -> [Char] -> XmlArrow
checkForName [Char]
"Attribute value" XmlTree
attrDecl [Char]
attrValue


-- |
-- Checks the value of IDREFS attribute types. (3.3.1 \/ p.26 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 2.parameter attrValue :  the normalized attribute value to be checked

checkValueIdrefs :: XmlTree -> String -> XmlArrow
checkValueIdrefs :: XmlTree -> [Char] -> XmlArrow
checkValueIdrefs XmlTree
attrDecl [Char]
attrValue
    = [XmlArrow] -> XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> ([Char] -> [XmlArrow]) -> [Char] -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> XmlArrow) -> [[Char]] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map (XmlTree -> [Char] -> XmlArrow
checkValueIdref XmlTree
attrDecl) ([[Char]] -> [XmlArrow])
-> ([Char] -> [[Char]]) -> [Char] -> [XmlArrow]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words ([Char] -> XmlArrow) -> [Char] -> XmlArrow
forall a b. (a -> b) -> a -> b
$ [Char]
attrValue



-- -----------------------------------------------------------------------------
-- General helper functions for checking attribute values
--

-- |
-- Checks if the value of an attribute is a name.
--
--    * 1.parameter msg :  error message, should be "Entity" or "Attribute value"
--
--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD
--
--    - 3.parameter attrValue :  the normalized attribute value to be checked

checkForName ::  String -> XmlTree -> String -> XmlArrow
checkForName :: [Char] -> XmlTree -> [Char] -> XmlArrow
checkForName [Char]
msg XmlTree
attrDecl [Char]
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = [Char] -> LA XmlTree [Char]
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA [Char]
attrValue LA XmlTree [Char] -> LA [Char] XmlTree -> XmlArrow
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> LA [Char] XmlTree
checkName
    | Bool
otherwise
        = XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
    where
    al :: Attributes
al  = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
    checkName :: LA [Char] XmlTree
checkName
        = LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => a [Char] XmlTree
mkText LA [Char] XmlTree -> XmlArrow -> LA [Char] XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (XmlTree -> XmlTrees) -> XmlArrow
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL ([Char] -> XmlTree -> XmlTrees
parseName [Char]
"")
          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 :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isError
          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
>>>
          LA XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => a XmlTree [Char]
getErrorMsg
          LA XmlTree [Char] -> LA [Char] XmlTree -> XmlArrow
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          ([Char] -> [Char]) -> LA [Char] [Char]
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\[Char]
s -> ( [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
attrValue [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" of attribute " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_value Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                       [Char]
" for element "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Attributes -> [Char]
dtd_name Attributes
al) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" must be a name, " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [[Char]]
lines [Char]
s) [[Char]] -> Int -> [Char]
forall a. [a] -> Int -> a
!! Int
1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".") )
          LA [Char] [Char] -> LA [Char] XmlTree -> LA [Char] XmlTree
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
          Int -> LA [Char] XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a [Char] XmlTree
mkError Int
c_err

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

-- |
-- Normalizes an attribute value with respect to its type. (3.3.3 \/ p.29 in Spec)
--
--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD. Expected
--                   is a list. If the list is empty, no declaration exists.
--
--    - 2.parameter value :  the attribute value to be normalized
--
--    - returns : the normalized value
--
normalizeAttributeValue :: Maybe XmlTree -> String -> String
normalizeAttributeValue :: Maybe XmlTree -> [Char] -> [Char]
normalizeAttributeValue (Just XmlTree
attrDecl) [Char]
value
    = [Char] -> [Char]
normalizeAttribute [Char]
attrType
      where
      al :: Attributes
al             = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      attrType :: [Char]
attrType = Attributes -> [Char]
dtd_type Attributes
al

      normalizeAttribute :: String -> String
      normalizeAttribute :: [Char] -> [Char]
normalizeAttribute [Char]
typ
          | [Char]
typ [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
k_cdata      = [Char] -> [Char]
cdataNormalization [Char]
value
          | Bool
otherwise           = [Char] -> [Char]
otherNormalization [Char]
value

-- Attribute not declared in DTD, normalization as CDATA
normalizeAttributeValue Maybe XmlTree
Nothing [Char]
value
    = [Char] -> [Char]
cdataNormalization [Char]
value

-- ------------------------------------------------------------
-- Helper functions for normalization

-- |
-- Normalization of CDATA attribute values.
-- is already done when parsing
-- during entity substituion for attribute values

cdataNormalization :: String -> String
cdataNormalization :: [Char] -> [Char]
cdataNormalization = [Char] -> [Char]
forall a. a -> a
id

-- | Normalization of attribute values other than CDATA.

otherNormalization :: String -> String
otherNormalization :: [Char] -> [Char]
otherNormalization = [Char] -> [Char]
reduceWSSequences ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
stringTrim ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
cdataNormalization

-- | Reduce whitespace sequences to a single whitespace.

reduceWSSequences :: String -> String
reduceWSSequences :: [Char] -> [Char]
reduceWSSequences [Char]
str = [[Char]] -> [Char]
unwords ([Char] -> [[Char]]
words [Char]
str)

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