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

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

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable
       Version    : $Id: DTDProcessing.hs,v 1.9 2006/05/11 14:47:19 hxml Exp $

       DTD processing function for
       including external parts of a DTD
       parameter entity substitution and general entity substitution

       Implemtation completely done with arrows

    -}

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

    module Text.XML.HXT.Arrow.DTDProcessing
        ( processDTD
        )
    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 qualified Text.XML.HXT.DOM.XmlNode as XN

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

    import Text.XML.HXT.Arrow.ParserInterface
        ( parseXmlDTDdecl
        , parseXmlDTDdeclPart
        , parseXmlDTDEntityValue
        , parseXmlDTDPart
        )

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

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

    import Data.Maybe

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

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

    data DTDPart            = Internal
                            | External
                              deriving (Eq)

    type RecList            = [String]

    type DTDStateArrow b c  = IOStateArrow PEEnv b c

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

    newtype PEEnv           = PEEnv (M.Map String XmlTree)

    emptyPeEnv      :: PEEnv
    emptyPeEnv      = PEEnv M.empty

    lookupPeEnv     :: String -> PEEnv -> Maybe XmlTree
    lookupPeEnv k (PEEnv env)
        = M.lookup k env

    addPeEntry      :: String -> XmlTree -> PEEnv -> PEEnv
    addPeEntry k a (PEEnv env)
        = PEEnv $ M.insert k a env

    getPeValue      :: DTDStateArrow String XmlTree
    getPeValue
        = (this &&& getUserState)
          >>>
          arrL (\ (n, env) -> maybeToList . lookupPeEnv n $ env)

    addPe           :: String -> DTDStateArrow XmlTree XmlTree
    addPe n
        = traceMsg 2 ("substParamEntity: add entity " ++ show n ++ " to env")
          >>>
          changeUserState ins
        where
        ins t peEnv = addPeEntry n t peEnv

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

    -- |
    -- a filter for DTD processing
    --
    -- inclusion of external parts of DTD,
    -- parameter entity substitution
    -- conditional section evaluation
    --
    -- input tree must represent a complete document including root node

    processDTD              :: IOStateArrow s XmlTree XmlTree
    processDTD
        = runInLocalURIContext
             ( processRoot
               >>>
               traceTree
               >>>
               traceSource
             )
          `when` ( isRoot >>> getChildren )
          where

          processRoot       :: IOStateArrow s XmlTree XmlTree
          processRoot
              = ( traceMsg 1 ("processDTD: process parameter entities")
                  >>>
                  setParamString a_standalone ""
                  >>>
                  ( addDocType
                    `whenNot`
                    ( getChildren >>> isDTDDoctype )
                  )
                  >>>
                  processChildren substParamEntities
                  >>>
                  setDocumentStatusFromSystemState "in XML DTD processing"
                )
                `when`
                documentStatusOk
              where
              addDocType
                  = replaceChildren ( (getChildren >>> isXmlPi)
                                      <+>
                                      mkDTDDoctype [] none
                                      <+>
                                      (getChildren >>> neg isXmlPi)
                                    )

    substParamEntities      :: IOStateArrow s XmlTree XmlTree
    substParamEntities
        = withOtherUserState emptyPeEnv processParamEntities
          `when`
          isDTDDoctype
          where

          processParamEntities      :: DTDStateArrow XmlTree XmlTree
          processParamEntities
              = mergeEntities $<<< ( listA processPredef
                                     &&&
                                     listA processInt
                                     &&&
                                     listA (runInLocalURIContext processExt)
                                   )
              where
              mergeEntities dtdPre dtdInt dtdExt
                  =  replaceChildren (arrL $ const $ foldl1 mergeDTDs [dtdPre, dtdInt, dtdExt])

              processPredef
                  = predefDTDPart   >>> substParamEntity Internal []

              processInt
                  = getChildren     >>> substParamEntity Internal []

              processExt
                  = externalDTDPart >>> substParamEntity External []

              mergeDTDs     :: XmlTrees -> XmlTrees -> XmlTrees
              mergeDTDs dtdInt dtdExt
                  = dtdInt ++ (filter (filterDTDNodes dtdInt) dtdExt)

              filterDTDNodes        :: XmlTrees -> XmlTree -> Bool
              filterDTDNodes dtdPart t
                  = not (any (filterDTDNode t) dtdPart)

              filterDTDNode :: XmlTree -> XmlTree -> Bool

              filterDTDNode t1 t2
                  = fromMaybe False $
                    do
                    dp1 <- XN.getDTDPart t1
                    dp2 <- XN.getDTDPart t2
                    al1 <- XN.getDTDAttrl t1
                    al2 <- XN.getDTDAttrl t2
                    return ( dp1 == dp2
                             &&
                             ( dp1 `elem` [ELEMENT, NOTATION, ENTITY, ATTLIST] )
                             &&
                             ( lookup a_name al1 == lookup a_name al2 )
                             &&
                             ( dp1 /= ATTLIST
                               ||
                               lookup a_value al1 == lookup a_value al2
                             )
                           )

    substParamEntity        :: DTDPart -> RecList -> DTDStateArrow XmlTree XmlTree
    substParamEntity loc recList
        = choiceA
          [ isDTDEntity     :-> ( traceDTD "ENTITY declaration before DTD declaration parsing"
                                  >>>
                                  processChildren (substPeRefsInDTDdecl recList)
                                  >>>
                                  parseXmlDTDdecl
                                  >>>
                                  substRefsInEntityValue
                                  >>>
                                  processEntityDecl
                                  >>>
                                  traceDTD "ENTITY declaration after DTD declaration parsing"
                                )
          , ( isDTDElement
              <+>
              isDTDAttlist
              <+>
              isDTDNotation
            )               :-> ( traceDTD "DTD declaration before PE substitution"
                                  >>>
                                  processChildren (substPeRefsInDTDdecl recList)
                                  >>>
                                  parseXmlDTDdecl
                                  >>>
                                  traceDTD "DTD declaration after DTD declaration parsing"
                                )
          , isDTDPERef      :-> substPeRefsInDTDpart recList

          , isDTDCondSect   :-> ( if loc == Internal
                                  then issueErr "conditional sections in internal part of the DTD is not allowed"
                                  else evalCondSect $< getDTDAttrValue a_value
                                )
          , isCmt           :-> none
          , this            :-> this
          ]
        where
        processEntityDecl           :: DTDStateArrow XmlTree XmlTree
        processEntityDecl
            = choiceA
              [ isDTDEntity :-> ( ifA (hasDTDAttr k_system)
                                  processExternalEntity
                                  processInternalEntity
                                )
              , isDTDPEntity
                            :-> ( processParamEntity $< getDTDAttrValue a_name )
              , this        :-> none
              ]
            where
            processExternalEntity   :: DTDStateArrow XmlTree XmlTree        -- processing external entities is delayed until first usage
            processExternalEntity                                           -- only the current base uri must be remembered
                = setDTDAttrValue a_url $< ( getDTDAttrValue k_system >>> mkAbsURI )

            processInternalEntity   :: DTDStateArrow XmlTree XmlTree        -- just combine all parts of the entity value
            processInternalEntity                                           -- into one string
                = replaceChildren (xshow getChildren >>> mkText)

            processParamEntity      :: String -> DTDStateArrow XmlTree XmlTree
            processParamEntity peName
                = ifA (constA peName >>> getPeValue)
                  ( issueWarn ("parameter entity " ++ show peName ++ " already defined") )
                  ( ( ifA ( hasDTDAttr k_system )                           -- is external param entity ?
                      ( runInLocalURIContext getExternalParamEntityValue )
                      ( replaceChildren (xshow getChildren >>> mkText) )    -- just combine all parts of the entity value into one string
                    )
                    >>>
                    addPe peName
                  )

        substPERef                  :: String -> DTDStateArrow XmlTree XmlTree
        substPERef pn
            = choiceA
              [ isInternalRef       :-> issueErr ("a parameter entity reference of " ++ show pn ++ " occurs in the internal subset of the DTD")
              , isUndefinedRef      :-> issueErr ("parameter entity " ++ show pn ++ " not found (forward reference?)")
              , this                :-> substPE
              ]
              `when`
              isDTDPERef
            where
            isInternalRef   = isA (const (loc == Internal))
            peVal           = constA pn >>> getPeValue
            isUndefinedRef  = neg peVal
            substPE
                = replaceChildren (peVal >>> getChildren)                   -- store PE value in children component
                  >>>
                  ( ( setBase $< (peVal >>> getDTDAttrValue a_url) )        -- store base uri for external refs
                    `orElse`
                    this
                  )
                where
                setBase uri = setDTDAttrValue a_url uri

        substRefsInEntityValue      :: DTDStateArrow XmlTree XmlTree
        substRefsInEntityValue
            = ( ( processChildren ( transfCharRef
                                    >>>
                                    substPeRefsInValue []
                                  )
                )
                `whenNot`
                hasDTDAttr k_system                                         -- only apply for internal entities
              )
              `when`
              ( isDTDEntity <+> isDTDPEntity )                              -- only apply for entity declarations

        substPeRefsInDTDpart        :: RecList -> DTDStateArrow XmlTree XmlTree
        substPeRefsInDTDpart rl
            = recursionCheck "DTD part" rl subst
            where
            subst   :: RecList -> String -> DTDStateArrow XmlTree XmlTree
            subst recl pn
                = substPERef pn
                  >>>
                  traceDTD "substPeRefsInDTDdecl: before parseXmlDTDPart"
                  >>>
                  ( runInPeContext ( getChildren
                                     >>>
                                     ( (constA ("parameter entity: " ++ pn)) &&& this )
                                     >>>
                                     parseXmlDTDPart
                                     >>>
                                     traceDTD "substPeRefsInDTDpart: after parseXmlDTDPart"
                                     >>>
                                     substParamEntity loc (pn : recl)
                                   )
                    `when`
                    isDTDPERef
                  )

        substPeRefsInDTDdecl        :: RecList -> DTDStateArrow XmlTree XmlTree
        substPeRefsInDTDdecl rl
            = recursionCheck "DTD declaration" rl subst
            where
            subst   :: RecList -> String -> DTDStateArrow XmlTree XmlTree
            subst recl pn
                = substPERef pn
                  >>>
                  traceDTD "substPeRefsInDTDdecl: before parseXmlDTDdeclPart"
                  >>>
                  ( runInPeContext ( parseXmlDTDdeclPart
                                     >>>
                                     traceDTD "substPeRefsInDTDdecl: after parseXmlDTDdeclPart"
                                     >>>
                                     processChildren ( substPeRefsInDTDdecl (pn : recl) )
                                   )
                    `when`
                    isDTDPERef
                  )

        substPeRefsInValue          :: RecList -> DTDStateArrow XmlTree XmlTree
        substPeRefsInValue rl
            = recursionCheck "entity value" rl subst
            where
            subst   :: RecList -> String -> DTDStateArrow XmlTree XmlTree
            subst recl pn
                = substPERef pn
                  >>>
                  parseXmlDTDEntityValue
                  >>>
                  transfCharRef
                  >>>
                  substPeRefsInValue (pn : recl)

        substPeRefsInCondSect       :: RecList -> DTDStateArrow XmlTree XmlTree
        substPeRefsInCondSect rl
            = recursionCheck "conditional section" rl subst
            where
            subst   :: RecList -> String -> DTDStateArrow XmlTree XmlTree
            subst recl pn
                = substPERef pn
                  >>>
                  traceDTD "substPeRefsInCondSect: parseXmlDTDdeclPart"
                  >>>
                  runInPeContext ( parseXmlDTDdeclPart
                                   >>>
                                   traceDTD "substPeRefsInCondSect: after parseXmlDTDdeclPart"
                                   >>>
                                   processChildren ( substPeRefsInCondSect (pn : recl) )
                                 )

        recursionCheck      :: String -> RecList -> (RecList -> String -> DTDStateArrow XmlTree XmlTree) -> DTDStateArrow XmlTree XmlTree
        recursionCheck wher rl subst
            = ( recusiveSubst  $< getDTDAttrValue a_peref )
              `when`
              isDTDPERef
            where
            recusiveSubst name
                | name `elem` rl
                    = issueErr ("recursive call of parameter entity " ++ show name ++ " in " ++ wher)
                | otherwise
                    = subst rl name

        runInPeContext      :: DTDStateArrow XmlTree XmlTree -> DTDStateArrow XmlTree XmlTree
        runInPeContext f
            = ( runWithNewBase $< getDTDAttrValue a_url )
              `orElse`
              f
            where
            runWithNewBase base
                = runInLocalURIContext
                  ( perform (constA base >>> setBaseURI)
                    >>>
                    f
                  )

        evalCondSect        :: String ->  DTDStateArrow XmlTree XmlTree
        evalCondSect content
            = traceDTD "evalCondSect: process conditional section"
              >>>
              processChildren (substPeRefsInCondSect [])
              >>>
              parseXmlDTDdecl
              >>>
              ( hasText (== k_include)
                `guards`
                ( ( constA "conditional section" &&& txt content )
                  >>>
                  parseXmlDTDPart
                  >>>
                  traceMsg 2 "evalCond: include DTD part"
                  >>>
                  substParamEntity External recList
                )
              )

    predefDTDPart           :: DTDStateArrow XmlTree XmlTree
    predefDTDPart
        = ( constA "predefined entities"
            &&&
            ( constA predefinedEntities >>> mkText)
          )
          >>>
          parseXmlDTDPart
        where
        predefinedEntities  :: String
        predefinedEntities
            = concat [ "<!ENTITY lt   '&#38;#60;'>"
                     , "<!ENTITY gt   '&#62;'>"
                     , "<!ENTITY amp  '&#38;#38;'>"
                     , "<!ENTITY apos '&#39;'>"
                     , "<!ENTITY quot '&#34;'>"
                     ]

    externalDTDPart         :: DTDStateArrow XmlTree XmlTree
    externalDTDPart
        = isDTDDoctype
          `guards`
          ( hasDTDAttr k_system
            `guards`
            ( getExternalDTDPart $< getDTDAttrValue k_system )
          )

    getExternalDTDPart      :: String -> DTDStateArrow XmlTree XmlTree
    getExternalDTDPart src
        = root [sattr a_source src] []
          >>>
          getXmlEntityContents
          >>>
          replaceChildren ( ( constA src &&& getChildren )
                            >>>
                            parseXmlDTDPart
                          )
          >>>
          traceDoc "processExternalDTD: parsing DTD part done"
          >>>
          getChildren

    getExternalParamEntityValue     :: DTDStateArrow XmlTree XmlTree
    getExternalParamEntityValue
        = isDTDPEntity
          `guards`
          ( setEntityValue $<<< ( getDTDAttrl
                                  &&&
                                  listA ( getEntityValue $< getDTDAttrl )
                                  &&&
                                  getBaseURI
                                )
          )
        where
        getEntityValue      :: Attributes -> DTDStateArrow XmlTree XmlTree
        getEntityValue al
            = root [sattr a_source (lookup1 k_system al){- <+> catA (map (uncurry sattr) al)-}] []
              >>>
              getXmlEntityContents
              >>>
              traceMsg 2 "getExternalParamEntityValue: contents read"
              >>>
              getChildren

        setEntityValue      :: Attributes -> XmlTrees -> String -> DTDStateArrow XmlTree XmlTree
        setEntityValue al res base
            | null res
                = issueErr ("illegal external parameter entity value for entity %" ++ peName ++";")
            | otherwise
                = mkDTDElem PENTITY ((a_url, base) : al) (arrL $ const res)
            where
            peName = lookup1 a_name al

    traceDTD        :: String -> DTDStateArrow XmlTree XmlTree
    traceDTD msg    = traceMsg 3 msg >>> traceTree

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