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

    {- |
       Module     : Text.XML.HXT.Arrow.GeneralEntitySubstitution
       Copyright  : Copyright (C) 2005 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable
       Version    : $Id: GeneralEntitySubstitution.hs,v 1.13 2006/05/01 18:56:24 hxml Exp $

       general entity substitution

    -}

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

    module Text.XML.HXT.Arrow.GeneralEntitySubstitution
        ( processGeneralEntities )
    where

    import Control.Arrow				-- arrow classes
    import Control.Arrow.ArrowList
    import Control.Arrow.ArrowIf
    import Control.Arrow.ArrowTree

    import Text.XML.HXT.DOM.Interface
    import Text.XML.HXT.Arrow.XmlArrow
    import Text.XML.HXT.Arrow.XmlIOStateArrow

    import Text.XML.HXT.Arrow.ParserInterface
        ( parseXmlAttrValue
        , parseXmlGeneralEntityValue
        )

    import Text.XML.HXT.Arrow.Edit
        ( transfCharRef
        )

    import Text.XML.HXT.Arrow.DocumentInput
        ( getXmlEntityContents
        )

    import qualified Data.Map as M
        ( Map
        , empty
        , lookup
        , insert
        )

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

    data GEContext
        = ReferenceInContent
        | ReferenceInAttributeValue
        | ReferenceInEntityValue
        -- or OccursInAttributeValue				-- not used during substitution but during validation
        -- or ReferenceInDTD					-- not used: syntax check detects errors

    type GESubstArrow	= GEContext -> RecList -> GEArrow XmlTree XmlTree

    type GEArrow b c	= IOStateArrow GEEnv b c

    type RecList		= [String]

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

    newtype GEEnv	= GEEnv (M.Map String GESubstArrow)

    emptyGeEnv	:: GEEnv
    emptyGeEnv	= GEEnv M.empty

    lookupGeEnv		:: String -> GEEnv -> Maybe GESubstArrow
    lookupGeEnv k (GEEnv env)
        = M.lookup k env

    addGeEntry	:: String -> GESubstArrow -> GEEnv -> GEEnv
    addGeEntry k a (GEEnv env)
        = GEEnv $ M.insert k a env

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

    -- |
    -- substitution of general entities
    --
    -- input: a complete document tree including root node

    processGeneralEntities	:: IOStateArrow s XmlTree XmlTree
    processGeneralEntities
        = ( traceMsg 1 "processGeneralEntities: collect and substitute general entities"
    	>>>
    	withOtherUserState emptyGeEnv (processChildren (processGeneralEntity ReferenceInContent []))
    	>>>
    	setDocumentStatusFromSystemState "in general entity processing"
    	>>>
    	traceTree
    	>>>
    	traceSource
          )
          `when`
          documentStatusOk

    processGeneralEntity	:: GESubstArrow
    processGeneralEntity context recl
        = choiceA [ isElem		:-> ( processAttrl (processChildren substEntitiesInAttrValue)
    		                      >>>
    		                      processChildren (processGeneralEntity context recl)
    				    )
    	      , isDTDDoctype	:-> processChildren (processGeneralEntity context recl)
    	      , isDTDEntity	:-> addEntityDecl
    	      , isDTDAttlist	:-> substEntitiesInAttrDefaultValue
    	      , isEntityRef	:-> substEntityRef
    	      , this 		:-> this
    	      ]
        where
        addEntityDecl	:: GEArrow XmlTree XmlTree
        addEntityDecl
    	= perform ( choiceA [ isIntern		:-> addInternalEntity		-- don't change sequence of cases
    			    , isExtern		:-> addExternalEntity
    			    , isUnparsed	:-> addUnparsedEntity
    			    ]
    		  )
    	where
    	isIntern	= none `when` hasDTDAttr k_system
    	isExtern	= none `when` hasDTDAttr k_ndata
    	isUnparsed	= this

        addInternalEntity	:: GEArrow XmlTree b
        addInternalEntity
    	= ( ( getDTDAttrValue a_name
    	      >>>
    	      traceValue 2 (("processGeneralEntity: general entity definition for " ++) . show)
    	    )
    	    &&&
    	    xshow (getChildren >>> isText)
    	  )
              >>>
    	  applyA ( arr2 $ \ entity str ->
    		   listA ( ( ( txt str
    			       >>>
    			       parseXmlGeneralEntityValue ("general internal entity" ++ show entity)
    			       >>>
    			       filterErrorMsg
    			     )
    			     `orElse` txt ""
    			   )
    			   >>>
    			   processGeneralEntity ReferenceInEntityValue (entity : recl)
    			 )
    		   >>>
    		   applyA (arr $ \ ts -> insertEntity (substInternal ts) entity)
    		 )
    	  >>>
    	  none

        addExternalEntity	:: GEArrow XmlTree b
        addExternalEntity
    	= ( ( getDTDAttrValue a_name
    	      >>>
    	      traceValue 2 (("processGeneralEntity: external entity definition for " ++) . show)
                )
    	    &&&
    	    getDTDAttrValue a_url 			-- the absolute URL, not the relative in attr: k_system
    	  )
    	  >>>
    	  applyA (arr2 $ \ entity uri -> insertEntity (substExternalParsed1Time uri) entity)
    	  >>>
    	  none

        addUnparsedEntity	:: GEArrow XmlTree b
        addUnparsedEntity
    	= getDTDAttrValue a_name
    	  >>>
    	  traceValue 2 (("processGeneralEntity: unparsed entity definition for " ++) . show)
              >>>
    	  applyA (arr (insertEntity substUnparsed))
    	  >>>
    	  none

        insertEntity	:: (String -> GESubstArrow) -> String -> GEArrow b b
        insertEntity fct entity
    	= ( getUserState
    	    >>>
    	    applyA (arr checkDefined)
    	  )
    	  `guards`
    	  addEntity fct entity
    	where
    	checkDefined geEnv
    	    = maybe ok alreadyDefined . lookupGeEnv entity $ geEnv
    	    where
    	    ok	= this
    	    alreadyDefined _
    		= issueWarn ("entity " ++ show entity ++ " already defined, repeated definition ignored")

        addEntity	:: (String -> GESubstArrow) -> String -> GEArrow b b
        addEntity fct entity
    	= changeUserState ins
    	where
    	ins _ geEnv = addGeEntry entity (fct entity) geEnv

        substEntitiesInAttrDefaultValue	:: GEArrow XmlTree XmlTree
        substEntitiesInAttrDefaultValue
    	= applyA ( xshow ( getDTDAttrValue a_default			-- parse the default value
    			   >>>						-- substitute entities
    			   mkText					-- and convert value into a string
    			   >>>
    			   parseXmlAttrValue "default value of attribute"
    			   >>>
    			   filterErrorMsg
    			   >>>
    			   substEntitiesInAttrValue
    			 )
    		   >>> arr (setDTDAttrValue a_default)
    		 )
              `when` hasDTDAttr a_default

        substEntitiesInAttrValue	:: GEArrow XmlTree XmlTree
        substEntitiesInAttrValue
    	= ( processGeneralEntity ReferenceInAttributeValue recl
    	    `when`
    	    isEntityRef
    	  )
              >>>
    	  changeText normalizeWhiteSpace
    	  >>>
    	  transfCharRef
    	where
    	normalizeWhiteSpace = map ( \c -> if c `elem` "\n\t\r" then ' ' else c )

        substEntityRef	:: GEArrow XmlTree XmlTree
        substEntityRef
    	= applyA ( ( ( getEntityRef				-- get the entity name and the env
    		       >>>					-- and compute the arrow to be applied
    		       traceValue 2 (("processGeneralEntity: entity reference for entity " ++) . show)
    		       >>>
    		       traceMsg 3 ("recursion list = " ++ show recl)
    		     )
    		     &&&
    		     getUserState
    		   ) >>>
    		   arr2 substA
    		 )
    	  `orElse` this
    	  where
    	  substA	:: String -> GEEnv -> GEArrow XmlTree XmlTree
    	  substA entity geEnv
    	      = maybe entityNotFound entityFound . lookupGeEnv entity $ geEnv
    	      where
    	      errMsg msg
    		  = issueErr msg

    	      entityNotFound
    		  = errMsg ("general entity reference \"&" ++ entity ++ ";\" not processed, no definition found, (forward reference?)")

    	      entityFound fct
    		  | entity `elem` recl
    		      = errMsg ("general entity reference \"&" ++ entity ++ ";\" not processed, cyclic definition")
    		  | otherwise
    		      = fct context recl

        substExternalParsed1Time				:: String -> String -> GESubstArrow
        substExternalParsed1Time uri entity cx rl
     	= perform ( traceMsg 2 ("substExternalParsed1Time: read and parse external parsed entity " ++ show entity)
    		    >>>
    		    runInLocalURIContext ( root [sattr a_source uri] []		-- uri must be an absolute uri
    					   >>>					-- abs uri is computed during parameter entity handling
    					   listA ( getXmlEntityContents
    						   >>>
    						   processExternalEntityContents
    						 )
    					 )
    		    >>>
    		    applyA ( arr $ \ ts -> addEntity (substExternalParsed ts) entity )
    		  )
    	  >>>
    	  processGeneralEntity cx rl
    	where
    	processExternalEntityContents	:: IOStateArrow s XmlTree XmlTree
    	processExternalEntityContents
    	    = ( ( documentStatusOk				-- reading entity succeeded
    		  >>>						-- with content stored in a text node
    		  (getChildren >>> isText)
    		)
    		`guards`
    		( getChildren
    		  >>>
    		  parseXmlGeneralEntityValue ("external parsed entity " ++ show entity)
    		  >>>
    		  filterErrorMsg
    		)
    	      )
    	      `orElse`
    	      issueErr ("illegal value for external parsed entity " ++ show entity)

        substExternalParsed					:: XmlTrees -> String -> GESubstArrow
        substExternalParsed	ts entity ReferenceInContent rl	= includedIfValidating ts rl entity
        substExternalParsed	_  entity ReferenceInAttributeValue _
                                                            = forbidden entity "external parsed general" "in attribute value"
        substExternalParsed	_  _      ReferenceInEntityValue _
                                                            = bypassed

        substInternal					:: XmlTrees -> String -> GESubstArrow
        substInternal ts entity ReferenceInContent rl	= included          ts rl entity
        substInternal ts entity ReferenceInAttributeValue rl= includedInLiteral ts rl entity
        substInternal _  _      ReferenceInEntityValue _	= bypassed

        substUnparsed					:: String -> GESubstArrow
        substUnparsed entity ReferenceInContent        _	= forbidden entity "unparsed" "content"
        substUnparsed entity ReferenceInAttributeValue _	= forbidden entity "unparsed" "attribute value"
        substUnparsed entity ReferenceInEntityValue    _	= forbidden entity "unparsed" "entity value"

    									-- XML 1.0 chapter 4.4.2
        included		:: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree
        included ts rl entity
    	= arrL (const ts)
    	  >>>
    	  processGeneralEntity context (entity : rl)

    									-- XML 1.0 chapter 4.4.3
        includedIfValidating		:: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree
        includedIfValidating
    	= included

    									-- XML 1.0 chapter 4.4.4
        forbidden		:: String -> String -> String -> GEArrow XmlTree XmlTree
        forbidden entity msg cx
     	= issueErr ("reference of " ++ msg ++ show entity ++ " forbidden in " ++ cx)

    									-- XML 1.0 chapter 4.4.5
        includedInLiteral		:: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree
        includedInLiteral
    	= included

    									-- XML 1.0 chapter 4.4.7
        bypassed		:: GEArrow XmlTree XmlTree
        bypassed
    	= this

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