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

{- |
   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 dtdPart attrDecl
    | isDTDAttlistNode attrDecl
	= choiceA
	  [ isElem       :-> ( checkAttrVal $< getAttrValue attrName )
	  , isDTDAttlist :-> ( checkAttrVal $< (getDTDAttrl >>^ dtd_default) )
	  , this	     :-> none
	  ]
    | otherwise
	= none
      where
      al	= getDTDAttributes attrDecl
      attrName	= dtd_value al
      attrType  = dtd_type  al
      checkAttrVal attrValue
	  = checkValue attrType dtdPart normalizedVal attrDecl
	    where
	    normalizedVal = normalizeAttributeValue (Just attrDecl) 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 typ dtdPart attrValue attrDecl
	| typ == k_cdata	= none
	| typ == k_enumeration	= checkValueEnumeration attrDecl attrValue
	| typ == k_entity	= checkValueEntity dtdPart attrDecl attrValue
	| typ == k_entities	= checkValueEntities dtdPart attrDecl attrValue
	| typ == k_id		= checkValueId attrDecl attrValue
	| typ == k_idref	= checkValueIdref attrDecl attrValue
	| typ == k_idrefs	= checkValueIdrefs attrDecl attrValue
	| typ == k_nmtoken	= checkValueNmtoken attrDecl attrValue
	| typ == k_nmtokens	= checkValueNmtokens attrDecl attrValue
	| typ == k_notation	= checkValueEnumeration attrDecl attrValue
	| otherwise		= error ("Attribute type " ++ show typ ++ " 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 attrDecl attrValue
    | isDTDAttlistNode attrDecl
      &&
      attrValue `notElem` enumVals
	= err ( "Attribute " ++ show (dtd_value al) ++ " for element " ++ show (dtd_name al) ++
                " must have a value from list "++ show enumVals {- ++ " but has value " ++ show attrValue-} ++ ".")
    | otherwise
	= none
      where
      al	= getDTDAttributes attrDecl

      enumVals :: [String]
      enumVals = map (dtd_name . getDTDAttributes) $ (runLA getChildren 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 dtdPart attrDecl attrValue
    | isDTDAttlistNode attrDecl
      &&
      attrValue `notElem` upEntities
	= err ( "Entity " ++ show attrValue ++ " of attribute " ++ show (dtd_value al) ++
                " for element " ++ show (dtd_name al) ++ " is not unparsed. " ++
                "The following unparsed entities exist: " ++ show upEntities ++ ".")
    | otherwise
	= none
      where
      al	= getDTDAttributes attrDecl

      upEntities :: [String]
      upEntities = map (dtd_name . getDTDAttributes) (isUnparsedEntity $$ 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 dtdPart attrDecl attrValue
    | isDTDAttlistNode attrDecl
	= if null valueList
	  then err ("Attribute " ++ show (dtd_value al) ++ " of element " ++
                    show (dtd_name al) ++ " must be one or more names.")
          else catA . map (checkValueEntity dtdPart attrDecl) $ valueList
    | otherwise
	= none
      where
      al	= getDTDAttributes attrDecl
      valueList = words 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 attrDecl attrValue
    | isDTDAttlistNode attrDecl
	= constA attrValue >>> checkNmtoken
    | otherwise
	= none
      where
      al	= getDTDAttributes attrDecl
      checkNmtoken
	  = mkText >>> arrL (parseNMToken "")
	    >>>
	    isError
	    >>>
	    getErrorMsg
	    >>>
	    arr (\ s -> ( "Attribute value " ++ show attrValue ++ " of attribute " ++ show (dtd_value al) ++
			  " for element " ++ show (dtd_name al) ++ " must be a name token, "++ (lines s) !! 1 ++".") )
            >>>
	    mkError 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 attrDecl attrValue
    | isDTDAttlistNode attrDecl
	= if null valueList
	  then err ( "Attribute "++ show (dtd_value al) ++" of element " ++
                     show (dtd_name al) ++ " must be one or more name tokens.")
          else catA . map (checkValueNmtoken attrDecl) $ valueList
    | otherwise
	= none
      where
      al	= getDTDAttributes attrDecl
      valueList = words 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 attrDecl attrValue
    = checkForName "Attribute value" attrDecl 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 attrDecl attrValue
    = checkForName "Attribute value" attrDecl 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 attrDecl attrValue
    = catA . map (checkValueIdref attrDecl) . words $ 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 msg attrDecl attrValue
    | isDTDAttlistNode attrDecl
	= constA attrValue >>> checkName
    | otherwise
	= none
    where
    al	= getDTDAttributes attrDecl
    checkName
	= mkText >>> arrL (parseName "")
	  >>>
	  isError
	  >>>
	  getErrorMsg
	  >>>
	  arr (\s -> ( msg ++ " " ++ show attrValue ++" of attribute " ++ show (dtd_value al) ++
		       " for element "++ show (dtd_name al) ++" must be a name, " ++ (lines s) !! 1 ++ ".") )
          >>>
	  mkError 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 (Just attrDecl) value
    = normalizeAttribute attrType
      where
      al	     = getDTDAttributes attrDecl
      attrType = dtd_type al

      normalizeAttribute :: String -> String
      normalizeAttribute typ
          | typ == k_cdata	= cdataNormalization value
          | otherwise		= otherNormalization value

-- Attribute not declared in DTD, normalization as CDATA
normalizeAttributeValue Nothing value
    = cdataNormalization 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 = id

-- | Normalization of attribute values other than CDATA.

otherNormalization :: String -> String
otherNormalization = reduceWSSequences . stringTrim . cdataNormalization

-- | Reduce whitespace sequences to a single whitespace.

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

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