-- $Id: Namespace.hs,v 1.2 2004/06/22 14:38:52 graham Exp $
--------------------------------------------------------------------------------

-- |This module process namespaces in an XML document, and should be used after
--  general entity substitution and validation has been performed.  The DTD
--  in the supplied document is

module Text.XML.HaXml.Namespace
  ( processNamespaces
  , buildNamespaces
  , applyNamespaces
  ) where

import Text.XML.HaXml.Combinators
  ( CTransform, CFilterI, CFilter
  , o, chip
  )

import Text.XML.HaXml.Traverse
  ( docReplaceContent
  )

import Text.XML.HaXml.Types
  ( DocumentI(..), Document
  , ContentI(..), Content
  , ElementI(..), Element
  , Attribute, AttValue(..)
  , ElementInfoset(..)
  , Namespace(..)
  , QName(..)
  )

-- Get definition of (Either String) as an instance of Monad:
import Control.Monad()
import Control.Monad.Error()


------------------------------------------------------------
--  Predefined namespaces

xmlpre = "xml"
xmlns  = "http://www.w3.org/XML/1998/namespace"


------------------------------------------------------------
--  Main function

-- |Process a supplied document, removing namespace declaration attributes
--  and replacing namespace-qualified element and attribute names with QNames.
processNamespaces :: DocumentI () -> DocumentI ElementInfoset
processNamespaces = docReplaceContent (applyNamespaces `o` buildNamespaces)


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

-- |Build namespaces filter.  Scans document removing xmlns:xx attributes,
--  and creating a new document containing ElementInfoset values that
--  reflect those namespace attributes.

buildNamespaces :: CTransform () ElementInfoset
buildNamespaces = mapXmlInfo includeNS includeXmlNS

--  Collect and strip namespace attributes from supplied content,
--  and update a supplied transformation to add them as new namespaces,
includeNS ::
    ContentI i -> (i->ElementInfoset) -> (ContentI i,i->ElementInfoset)
includeNS c@(CElem (Elem n i as cs)) f =
    (CElem (Elem n i (fst elemns) cs),addNS (snd elemns) . f)
    where
        elemns :: ([Attribute],[Namespace])
        elemns = (regroup . map attrns) as
        regroup ans = (concatMap fst ans,concatMap snd ans)
        attrns :: Attribute -> ([Attribute],[Namespace])
        attrns (QN "xmlns" Nothing,AttValue [Left av]) = ([],[NS "" av])
        attrns (QN ('x':'m':'l':'n':'s':':':pref) Nothing,AttValue [Left av])
                                                       = ([],[NS pref av])
        attrns a                                       = ([a],[])

--  Add supplied namespaces to element content information, else no change
addNS :: [Namespace] -> (ElementInfoset -> ElementInfoset)
addNS ns i = i { eiNamespaces=ns++eiNamespaces i }

--  Initial namespace transform adds xml namespace to element
includeXmlNS :: i -> ElementInfoset
includeXmlNS = const inew
    where
        inew = EI
            { eiNamespaces = [NS xmlpre xmlns]
            , eiBase       = ""
            , eiLang       = ""
            , eiSpace      = False
            }

{- trial data
t1 = CElem (Elem (QN "eg:doc" Nothing) ()
                  [(QN "xmlns:eg" Nothing,AttValue [Left "example/"])]
                  [])
(t2,f2) = includeNS t1 includeXmlNS
CElem (Elem n3 i3 as3 cs3) = t2
i4 = f2 i3
[t5] = buildNamespaces t1
t6 = applyNamespaces t5
-}

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

-- |Apply namespaces filter.  Each document element is required to
--  contain a list of applicable namespaces.  These are used to
--  map names in pref:local format to QName form.
applyNamespaces :: CFilterI ElementInfoset
applyNamespaces = chip applyNamespaces `o` applyElemNS
    --  The order of composition is intended to prevent processing of
    --  chidren of elements for which an error value is returned.

applyElemNS :: CFilterI ElementInfoset
applyElemNS = atip attrns `o` updateElem elemns
    where
        attrns (Elem _ i _ _) (n,av) = case mapNS (eiNamespaces i) n of
            Right n1 -> Right [(n1,av)]
            Left  e  -> Left e
                        -- error ("attrns: "++e)
        elemns (Elem n i as cs) = case mapNSDef (eiNamespaces i) n of
            Right n1 -> Right (Elem n1 i as cs)
            Left  e  -> Left e
                        -- error ("elemns: "++e++show (eiNamespaces i))


--  Namespace mapping function
mapNS :: [Namespace] -> QName -> Either String QName
mapNS _   qn@(QN _ (Just _)) = Right qn
mapNS nss qn@(QN n Nothing ) = case break (==':') n of
    (pre,':':loc) -> case findPrefix pre nss of
        ns@(Just _) -> Right (QN loc ns)
        Nothing     -> Left  ("No namespace declaration for "++pre++":")
    otherwise       -> Right qn

--  Namespace mapping function, also tries to apply a default namespace
mapNSDef :: [Namespace] -> QName -> Either String QName
mapNSDef nss qn = case mapNS nss qn of
    Right (QN n Nothing) -> Right (QN n (findPrefix "" nss))
    qn1                  -> qn1

--  Lookup namespace prefix
findPrefix :: String -> [Namespace] -> Maybe Namespace
findPrefix _   []                = Nothing
findPrefix pre (ns@(NS p u):nss) =
    if pre==p then Just ns else findPrefix pre nss


------------------------------------------------------------
--  Auxiliary functions
--
--  These are candidates for inclusion in some more generic module of
--  filter combinator helpers (or even module Combinators.hs)
--  [[[Traverse.hs is a likely target]]]
--  [[[Note that SubstituteGEFilter might use some of these functions.]]]

-- |Filter to transform information in all elements and child elements,
--  accumulating information from the root towards the leaves.
--
--  mkf returns the function applied to the current element information
--      based on the function supplied and content of the current element,
--      and also a new value for the current element.
--      Use (const id) if the information transformation function is not
--      modified depending on element content.
--
mapXmlInfo ::
    (ContentI i1->(i1->i2)->(ContentI i1,i1->i2)) -> (i1->i2)
    -> CTransform i1 i2
mapXmlInfo mkf f c@(CElem _) = updateElem fupd cnew
    where
        fupd (Elem n i as cs) = Right $
            (Elem n (fnew i) as (concatMap (mapXmlInfo mkf fnew) cs))
        (cnew,fnew) = mkf c f
    -- (This function cannot be implemented using existing filters because
    -- the current element must be updated similtaneously with the child
    -- elements to avoid a type violation.  The filter framework updates
    -- elements one tree level at a time.)
mapXmlInfo _ _ c = updateElem (error "mapXmlInfo unused update") c

-- |Process ATtributes In Place (initially modelled on 'chip').
--  The attribute function is applied to any attributes of of an element,
--  and the element rebuilt around the results.
--
atip :: (ElementI i->Attribute->Either String [Attribute]) -> CFilterI i
atip f (CElem e) =
    case updateAttr f e of
        Right elm -> [CElem elm]
        Left  err -> [CErr err]
atip f c = [c]

-- |Create transformation (or filter) to update an element
--  using a supplied function.
updateElem ::
    (ElementI i1 -> (Either String (ElementI i2))) -> CTransform i1 i2
updateElem f (CElem elm)    = case f elm of
                (Right newelm) -> [(CElem newelm)]
                (Left  err)    -> [(CErr  err   )]
updateElem _ (CString c cd) = [(CString c cd)]
updateElem _ (CRef    cref) = [(CRef    cref)]
updateElem _ (CMisc   misc) = [(CMisc   misc)]
updateElem _ (CErr    err ) = [(CErr    err )]

updateAttr ::
    (ElementI i->Attribute->Either String [Attribute])
    -> (ElementI i -> (Either String (ElementI i)))
updateAttr f e@(Elem n i as cs) =
    case sequence (map (f e) as) of
        Right ats -> Right (Elem n i (concat ats) cs)
        Left  err -> Left  err

-- |Return all attributes of an element.
elemAttrs :: ContentI i -> [Attribute]
elemAttrs (CElem (Elem _ _ as _)) = as
elemAttrs _                       = []

{-
-- |Apply functions to members of a pair, and return come combination
--  of the results.
pairf :: (a1->b1->c) -> (a->a1) -> (b->b1) -> (a,b) -> c
pairf c fa fb (a,b) = c (fa a) (fb b)

pair :: (a->a1) -> (b->b1) -> (a,b) -> (a1,b1)
pair = pairf (,)
-}

--------------------------------------------------------------------------------
-- $Log: Namespace.hs,v $
-- Revision 1.2  2004/06/22 14:38:52  graham
-- Basic namespace processing is working.
-- Some problems with attribute handling/normalization still to be fixed.
--
-- Revision 1.1  2004/06/21 19:04:26  graham
-- Namespace processing filter compiles OK.
--