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

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

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