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

{- |
   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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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
:-> ( String -> XmlArrow
checkAttrVal (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
forall c b d. (c -> LA b d) -> LA b c -> LA b d
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
attrName )
          , XmlArrow
forall (a :: * -> * -> *). ArrowDTD a => a XmlTree XmlTree
isDTDAttlist XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> ( String -> XmlArrow
checkAttrVal (String -> XmlArrow) -> LA XmlTree String -> XmlArrow
forall c b d. (c -> LA b d) -> LA b c -> LA b d
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 -> String) -> LA XmlTree String
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ Attributes -> String
dtd_default) )
          , XmlArrow
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this             XmlArrow -> XmlArrow -> IfThen XmlArrow XmlArrow
forall a b. a -> b -> IfThen a b
:-> XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
          ]
    | Bool
otherwise
        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      attrName :: String
attrName  = Attributes -> String
dtd_value Attributes
al
      attrType :: String
attrType  = Attributes -> String
dtd_type  Attributes
al
      checkAttrVal :: String -> XmlArrow
checkAttrVal String
attrValue
          = String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue String
attrType XmlTrees
dtdPart String
normalizedVal XmlTree
attrDecl
            where
            normalizedVal :: String
normalizedVal = Maybe XmlTree -> String -> String
normalizeAttributeValue (XmlTree -> Maybe XmlTree
forall a. a -> Maybe a
Just XmlTree
attrDecl) String
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 :: String -> XmlTrees -> String -> XmlTree -> XmlArrow
checkValue String
typ XmlTrees
dtdPart String
attrValue XmlTree
attrDecl
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_cdata        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_enumeration  = XmlTree -> String -> XmlArrow
checkValueEnumeration XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_entity       = XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_entities     = XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntities XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_id           = XmlTree -> String -> XmlArrow
checkValueId XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_idref        = XmlTree -> String -> XmlArrow
checkValueIdref XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_idrefs       = XmlTree -> String -> XmlArrow
checkValueIdrefs XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_nmtoken      = XmlTree -> String -> XmlArrow
checkValueNmtoken XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_nmtokens     = XmlTree -> String -> XmlArrow
checkValueNmtokens XmlTree
attrDecl String
attrValue
        | String
typ String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_notation     = XmlTree -> String -> XmlArrow
checkValueEnumeration XmlTree
attrDecl String
attrValue
        | Bool
otherwise             = String -> XmlArrow
forall a. HasCallStack => String -> a
error (String
"Attribute type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
typ String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 -> String -> XmlArrow
checkValueEnumeration XmlTree
attrDecl String
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
      Bool -> Bool -> Bool
&&
      String
attrValue String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
enumVals
        = String -> XmlArrow
forall n. String -> LA n XmlTree
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 (Attributes -> String
dtd_value Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
" must have a value from list "String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
enumVals {- ++ " but has value " ++ show attrValue-} String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
    | Bool
otherwise
        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl

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

      upEntities :: [String]
      upEntities :: [String]
upEntities = (XmlTree -> String) -> XmlTrees -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> String
dtd_name (Attributes -> String)
-> (XmlTree -> Attributes) -> XmlTree -> String
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 -> String -> XmlArrow
checkValueEntities XmlTrees
dtdPart XmlTree
attrDecl String
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
valueList
          then String -> XmlArrow
forall n. String -> LA n XmlTree
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 (Attributes -> String
dtd_value Attributes
al) 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 (Attributes -> String
dtd_name Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be one or more names.")
          else [XmlArrow] -> XmlArrow
forall b c. [LA b c] -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> ([String] -> [XmlArrow]) -> [String] -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> XmlArrow) -> [String] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map (XmlTrees -> XmlTree -> String -> XmlArrow
checkValueEntity XmlTrees
dtdPart XmlTree
attrDecl) ([String] -> XmlArrow) -> [String] -> XmlArrow
forall a b. (a -> b) -> a -> b
$ [String]
valueList
    | Bool
otherwise
        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      valueList :: [String]
valueList = String -> [String]
words String
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 -> String -> XmlArrow
checkValueNmtoken XmlTree
attrDecl String
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = String -> LA XmlTree String
forall c b. c -> LA b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
attrValue 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
>>> LA String XmlTree
checkNmtoken
    | Bool
otherwise
        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      checkNmtoken :: LA String XmlTree
checkNmtoken
          = LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
mkText LA String XmlTree -> XmlArrow -> LA String 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 b c. (b -> [c]) -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (String -> XmlTree -> XmlTrees
parseNMToken String
"")
            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 String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getErrorMsg
            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 String
forall b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ String
s -> ( String
"Attribute value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
attrValue String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of attribute " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
" for element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be a name token, "String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String]
lines String
s) [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
1 String -> String -> String
forall a. [a] -> [a] -> [a]
++String
".") )
            LA String String -> LA String XmlTree -> LA String 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 String XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a String 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 -> String -> XmlArrow
checkValueNmtokens XmlTree
attrDecl String
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
valueList
          then String -> XmlArrow
forall n. String -> LA n XmlTree
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 (Attributes -> String
dtd_value Attributes
al) 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 (Attributes -> String
dtd_name Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be one or more name tokens.")
          else [XmlArrow] -> XmlArrow
forall b c. [LA b c] -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> ([String] -> [XmlArrow]) -> [String] -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> XmlArrow) -> [String] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map (XmlTree -> String -> XmlArrow
checkValueNmtoken XmlTree
attrDecl) ([String] -> XmlArrow) -> [String] -> XmlArrow
forall a b. (a -> b) -> a -> b
$ [String]
valueList
    | Bool
otherwise
        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
      where
      al :: Attributes
al        = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      valueList :: [String]
valueList = String -> [String]
words String
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 -> String -> XmlArrow
checkValueId XmlTree
attrDecl String
attrValue
    = String -> XmlTree -> String -> XmlArrow
checkForName String
"Attribute value" XmlTree
attrDecl String
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 -> String -> XmlArrow
checkValueIdref XmlTree
attrDecl String
attrValue
    = String -> XmlTree -> String -> XmlArrow
checkForName String
"Attribute value" XmlTree
attrDecl String
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 -> String -> XmlArrow
checkValueIdrefs XmlTree
attrDecl String
attrValue
    = [XmlArrow] -> XmlArrow
forall b c. [LA b c] -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => [a b c] -> a b c
catA ([XmlArrow] -> XmlArrow)
-> (String -> [XmlArrow]) -> String -> XmlArrow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> XmlArrow) -> [String] -> [XmlArrow]
forall a b. (a -> b) -> [a] -> [b]
map (XmlTree -> String -> XmlArrow
checkValueIdref XmlTree
attrDecl) ([String] -> [XmlArrow])
-> (String -> [String]) -> String -> [XmlArrow]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words (String -> XmlArrow) -> String -> XmlArrow
forall a b. (a -> b) -> a -> b
$ String
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 :: String -> XmlTree -> String -> XmlArrow
checkForName String
msg XmlTree
attrDecl String
attrValue
    | XmlTree -> Bool
isDTDAttlistNode XmlTree
attrDecl
        = String -> LA XmlTree String
forall c b. c -> LA b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
attrValue 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
>>> LA String XmlTree
checkName
    | Bool
otherwise
        = XmlArrow
forall b c. LA b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none
    where
    al :: Attributes
al  = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
    checkName :: LA String XmlTree
checkName
        = LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
mkText LA String XmlTree -> XmlArrow -> LA String 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 b c. (b -> [c]) -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL (String -> XmlTree -> XmlTrees
parseName String
"")
          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 String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getErrorMsg
          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 String
forall b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\String
s -> ( String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
attrValue String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" of attribute " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Attributes -> String
dtd_value Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                       String
" for element "String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Attributes -> String
dtd_name Attributes
al) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
" must be a name, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String]
lines String
s) [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") )
          LA String String -> LA String XmlTree -> LA String 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 String XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a String 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 -> String -> String
normalizeAttributeValue (Just XmlTree
attrDecl) String
value
    = String -> String
normalizeAttribute String
attrType
      where
      al :: Attributes
al             = XmlTree -> Attributes
getDTDAttributes XmlTree
attrDecl
      attrType :: String
attrType = Attributes -> String
dtd_type Attributes
al

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

-- Attribute not declared in DTD, normalization as CDATA
normalizeAttributeValue Maybe XmlTree
Nothing String
value
    = String -> String
cdataNormalization String
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 :: String -> String
cdataNormalization = String -> String
forall a. a -> a
id

-- | Normalization of attribute values other than CDATA.

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

-- | Reduce whitespace sequences to a single whitespace.

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

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