{-# LANGUAGE PatternGuards #-}
module Text.XML.HaXml.Namespaces
  ( nullNamespace
  , expandedName
  , namespaceName
  , localName
  , printableName
  , qualify
  , deQualify
  , qualifyExceptLocal
  , initNamespaceEnv
  , augmentNamespaceEnv
  , resolveAllNames
  ) where

import Prelude hiding (lookup)
import Text.XML.HaXml.Types
import Data.Map as Map (Map, insert, lookup, empty)
import Data.List (isPrefixOf)

-- | The null Namespace (no prefix, no URI).
nullNamespace :: Namespace
nullNamespace :: Namespace
nullNamespace  = Namespace :: String -> String -> Namespace
Namespace { nsPrefix :: String
nsPrefix=String
"", nsURI :: String
nsURI=String
"" }

-- | Every Name can be split into a Namespace and local Name.  The Namespace
--   might of course be missing.
expandedName   :: QName -> (Maybe Namespace, String)
expandedName :: QName -> (Maybe Namespace, String)
expandedName QName
n  = (QName -> Maybe Namespace
namespaceName QName
n, QName -> String
localName QName
n)

-- | Return the (possibly absent) Namespace component of a Name.
namespaceName          :: QName -> Maybe Namespace
namespaceName :: QName -> Maybe Namespace
namespaceName (N String
_)     = Maybe Namespace
forall a. Maybe a
Nothing
namespaceName (QN Namespace
ns String
_) = Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
ns

-- | Return the local component of a Name, without its Namespace.
localName          :: QName -> String
--localName (N n)     | ':'`elem`n = tail $ dropWhile (/=':') n
localName :: QName -> String
localName (N String
n)     = String
n
localName (QN Namespace
_ String
n)  = String
n

-- | Return the printable string for a Name, i.e. attaching a prefix
--   for its namespace (if it has one).
printableName :: QName -> String
printableName :: QName -> String
printableName (N String
n)     = String
n
printableName (QN Namespace
ns String
n) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Namespace -> String
nsPrefix Namespace
ns) = String
n
                        | Bool
otherwise          = Namespace -> String
nsPrefix Namespace
nsString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:String
n

-- | 'qualify' splits a Name of the form "pr:nm" into the
--   prefix "pr" and local name "nm", and looks up the prefix in the
--   given environment to determine its Namespace.  There may also be a
--   default namespace (the first argument) for unqualified names.
--   In the absence of a default Namespace, a Name that does not have
--   a prefix remains unqualified.  A prefix that is not known in the
--   environment becomes a fresh namespace with null URI.  A Name that is
--   already qualified is passed unchanged, unless its URI was null, in
--   which case we check afresh for that prefix in the environment.
qualify :: Maybe Namespace -> Map String Namespace -> QName -> QName
qualify :: Maybe Namespace -> Map String Namespace -> QName -> QName
qualify Maybe Namespace
def Map String Namespace
env (N String
n)
        | Char
':'Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
n      = let (String
pre,Char
':':String
nm) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') String
n in
                            Namespace -> String -> QName
QN (Namespace
-> (Namespace -> Namespace) -> Maybe Namespace -> Namespace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Namespace
nullNamespace{nsPrefix :: String
nsPrefix=String
pre} Namespace -> Namespace
forall a. a -> a
id
                                      (String -> Map String Namespace -> Maybe Namespace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
pre Map String Namespace
env))
                               String
nm
        | Just Namespace
d <- Maybe Namespace
def   = Namespace -> String -> QName
QN Namespace
d String
n
        | Bool
otherwise       = String -> QName
N String
n
qualify Maybe Namespace
_ Map String Namespace
env qn :: QName
qn@(QN Namespace
ns String
n)
        | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Namespace -> String
nsURI Namespace
ns) = Namespace -> String -> QName
QN (Namespace
-> (Namespace -> Namespace) -> Maybe Namespace -> Namespace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Namespace
ns Namespace -> Namespace
forall a. a -> a
id (String -> Map String Namespace -> Maybe Namespace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace -> String
nsPrefix Namespace
ns) Map String Namespace
env)) String
n
        | Bool
otherwise       = QName
qn

-- | 'deQualify' has the same signature as 'qualify', but ignores the
--   arguments for default namespace and environment, and simply removes any
--   pre-existing qualification.
deQualify :: Maybe Namespace -> Map String Namespace -> QName -> QName
deQualify :: Maybe Namespace -> Map String Namespace -> QName -> QName
deQualify Maybe Namespace
_ Map String Namespace
_ (QN Namespace
_ String
n) = String -> QName
N String
n
deQualify Maybe Namespace
_ Map String Namespace
_ (N String
n)    = String -> QName
N String
n

-- | 'qualifyExceptLocal' converts names to qualified names, except where
--   an existing qualification matches the default namespace, in which case
--   the qualification is removed.  (This is useful when translating QNames
--   to Haskell, because Haskell qualified names cannot use the current
--   module name.)
qualifyExceptLocal :: Maybe Namespace -> Map String Namespace -> QName -> QName
qualifyExceptLocal :: Maybe Namespace -> Map String Namespace -> QName -> QName
qualifyExceptLocal Maybe Namespace
Nothing    Map String Namespace
env  QName
qn   = Maybe Namespace -> Map String Namespace -> QName -> QName
qualify Maybe Namespace
forall a. Maybe a
Nothing Map String Namespace
env QName
qn
qualifyExceptLocal (Just Namespace
def) Map String Namespace
env (N String
n)
        | Char
':'Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
n      = let (String
pre,Char
':':String
nm) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') String
n in
                            if Namespace -> String
nsPrefix Namespace
def String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pre then String -> QName
N String
nm
                            else Namespace -> String -> QName
QN (Namespace
-> (Namespace -> Namespace) -> Maybe Namespace -> Namespace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Namespace
nullNamespace{nsPrefix :: String
nsPrefix=String
pre} Namespace -> Namespace
forall a. a -> a
id
                                          (String -> Map String Namespace -> Maybe Namespace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
pre Map String Namespace
env))
                                    String
nm
        | Bool
otherwise       = String -> QName
N String
n
qualifyExceptLocal (Just Namespace
def) Map String Namespace
env qn :: QName
qn@(QN Namespace
ns String
n)
        | Namespace
defNamespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
==Namespace
ns         = String -> QName
N String
n
        | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Namespace -> String
nsURI Namespace
ns) = Namespace -> String -> QName
QN (Namespace
-> (Namespace -> Namespace) -> Maybe Namespace -> Namespace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Namespace
ns Namespace -> Namespace
forall a. a -> a
id (String -> Map String Namespace -> Maybe Namespace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace -> String
nsPrefix Namespace
ns) Map String Namespace
env)) String
n
        | Bool
otherwise       = QName
qn

-- | The initial Namespace environment.  It always has bindings for the
--   prefixes 'xml' and 'xmlns'.
initNamespaceEnv :: Map String Namespace
initNamespaceEnv :: Map String Namespace
initNamespaceEnv =
      String -> Namespace -> Map String Namespace -> Map String Namespace
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
"xmlns" Namespace :: String -> String -> Namespace
Namespace{nsPrefix :: String
nsPrefix=String
"xmlns"
                                  ,nsURI :: String
nsURI=String
"http://www.w3.org/2000/xmlns/"}
    (Map String Namespace -> Map String Namespace)
-> Map String Namespace -> Map String Namespace
forall a b. (a -> b) -> a -> b
$ String -> Namespace -> Map String Namespace -> Map String Namespace
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
"xml"   Namespace :: String -> String -> Namespace
Namespace{nsPrefix :: String
nsPrefix=String
"xml"
                                  ,nsURI :: String
nsURI=String
"http://www.w3.org/XML/1998/namespace"}
    (Map String Namespace -> Map String Namespace)
-> Map String Namespace -> Map String Namespace
forall a b. (a -> b) -> a -> b
$ Map String Namespace
forall k a. Map k a
Map.empty

-- | Add a fresh Namespace into the Namespace environment.  It is not
--   permitted to rebind the prefixes 'xml' or 'xmlns', but that is not
--   checked here.
augmentNamespaceEnv :: Namespace -> Map String Namespace
                                 -> Map String Namespace
augmentNamespaceEnv :: Namespace -> Map String Namespace -> Map String Namespace
augmentNamespaceEnv Namespace
ns Map String Namespace
env = String -> Namespace -> Map String Namespace -> Map String Namespace
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Namespace -> String
nsPrefix Namespace
ns) Namespace
ns Map String Namespace
env
{-
augmentNamespaceEnv :: Namespace -> Map String Namespace
                                 -> Either String (Map String Namespace)
augmentNamespaceEnv ns env
    | nsPrefix ns == "xml"   = Left "cannot rebind the 'xml' namespace"
    | nsPrefix ns == "xmlns" = Left "cannot rebind the 'xmlns' namespace"
    | otherwise              = Right (Map.insert (nsPrefix ns) ns env)
-}

-- | resolveAllNames in a document, causes every name to be properly
--   qualified with its namespace.  There is a default namespace for any
--   name that was originally unqualified.  This is likely only useful when
--   dealing with parsed document, less useful when generating a document
--   from scratch.
resolveAllNames :: (Maybe Namespace -> Map String Namespace -> QName -> QName)
                   -> Document i -> Document i
resolveAllNames :: (Maybe Namespace -> Map String Namespace -> QName -> QName)
-> Document i -> Document i
resolveAllNames Maybe Namespace -> Map String Namespace -> QName -> QName
qualify (Document Prolog
prolog SymTab EntityDef
entities Element i
elm [Misc]
misc) =
    Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document (Prolog -> Prolog
walkProlog Prolog
prolog) SymTab EntityDef
entities
             (Maybe Namespace -> Map String Namespace -> Element i -> Element i
forall i.
Maybe Namespace -> Map String Namespace -> Element i -> Element i
walkElem Maybe Namespace
forall a. Maybe a
Nothing Map String Namespace
initNamespaceEnv Element i
elm) [Misc]
misc
  where
    qualifyInDTD :: QName -> QName
qualifyInDTD = Maybe Namespace -> Map String Namespace -> QName -> QName
qualify Maybe Namespace
forall a. Maybe a
Nothing Map String Namespace
initNamespaceEnv
    walkProlog :: Prolog -> Prolog
walkProlog (Prolog Maybe XMLDecl
xml [Misc]
misc0 Maybe DocTypeDecl
mDTD [Misc]
misc1) =
                Maybe XMLDecl -> [Misc] -> Maybe DocTypeDecl -> [Misc] -> Prolog
Prolog Maybe XMLDecl
xml [Misc]
misc0 (Maybe DocTypeDecl
-> (DocTypeDecl -> Maybe DocTypeDecl)
-> Maybe DocTypeDecl
-> Maybe DocTypeDecl
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe DocTypeDecl
forall a. Maybe a
Nothing (DocTypeDecl -> Maybe DocTypeDecl
forall a. a -> Maybe a
Just (DocTypeDecl -> Maybe DocTypeDecl)
-> (DocTypeDecl -> DocTypeDecl) -> DocTypeDecl -> Maybe DocTypeDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocTypeDecl -> DocTypeDecl
walkDTD) Maybe DocTypeDecl
mDTD) [Misc]
misc1
    walkDTD :: DocTypeDecl -> DocTypeDecl
walkDTD (DTD QName
qn Maybe ExternalID
ext [MarkupDecl]
mds)     = QName -> Maybe ExternalID -> [MarkupDecl] -> DocTypeDecl
DTD (QName -> QName
qualifyInDTD QName
qn) Maybe ExternalID
ext ((MarkupDecl -> MarkupDecl) -> [MarkupDecl] -> [MarkupDecl]
forall a b. (a -> b) -> [a] -> [b]
map MarkupDecl -> MarkupDecl
walkMD [MarkupDecl]
mds)
    --
    walkMD :: MarkupDecl -> MarkupDecl
walkMD (Element ElementDecl
ed)          = ElementDecl -> MarkupDecl
Element (ElementDecl -> ElementDecl
walkED ElementDecl
ed)
    walkMD (AttList AttListDecl
ald)         = AttListDecl -> MarkupDecl
AttList (AttListDecl -> AttListDecl
walkALD AttListDecl
ald)
    walkMD MarkupDecl
md                    = MarkupDecl
md
    --
    walkED :: ElementDecl -> ElementDecl
walkED (ElementDecl QName
qn ContentSpec
cs)   = QName -> ContentSpec -> ElementDecl
ElementDecl (QName -> QName
qualifyInDTD QName
qn) (ContentSpec -> ContentSpec
walkCS ContentSpec
cs)
    --
    walkCS :: ContentSpec -> ContentSpec
walkCS (ContentSpec CP
cp)      = CP -> ContentSpec
ContentSpec (CP -> CP
walkCP CP
cp)
    walkCS (Mixed Mixed
m)             = Mixed -> ContentSpec
Mixed (Mixed -> Mixed
walkM Mixed
m)
    walkCS ContentSpec
cs                    = ContentSpec
cs
    --
    walkCP :: CP -> CP
walkCP (TagName QName
qn Modifier
m)        = QName -> Modifier -> CP
TagName (QName -> QName
qualifyInDTD QName
qn) Modifier
m
    walkCP CP
cp                    = CP
cp
    --
    walkM :: Mixed -> Mixed
walkM (PCDATAplus [QName]
qns)       = [QName] -> Mixed
PCDATAplus ((QName -> QName) -> [QName] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map QName -> QName
qualifyInDTD [QName]
qns)
    walkM Mixed
PCDATA                 = Mixed
PCDATA
    --
    walkALD :: AttListDecl -> AttListDecl
walkALD (AttListDecl QName
qn [AttDef]
ads) = QName -> [AttDef] -> AttListDecl
AttListDecl (QName -> QName
qualifyInDTD QName
qn)
                                               ((AttDef -> AttDef) -> [AttDef] -> [AttDef]
forall a b. (a -> b) -> [a] -> [b]
map AttDef -> AttDef
walkAD [AttDef]
ads)
    --
    walkAD :: AttDef -> AttDef
walkAD (AttDef QName
qn AttType
at DefaultDecl
dd)     = QName -> AttType -> DefaultDecl -> AttDef
AttDef (QName -> QName
qualifyInDTD QName
qn) AttType
at DefaultDecl
dd
    --
    walkElem :: Maybe Namespace -> Map String Namespace -> Element i -> Element i
walkElem Maybe Namespace
def Map String Namespace
env (Elem QName
qn [Attribute]
attrs [Content i]
conts) =
                      QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (Maybe Namespace -> Map String Namespace -> QName -> QName
qualify Maybe Namespace
def' Map String Namespace
env' QName
qn)
                           ((Attribute -> Attribute) -> [Attribute] -> [Attribute]
forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
a,AttValue
v)-> (Maybe Namespace -> Map String Namespace -> QName -> QName
qualify Maybe Namespace
forall a. Maybe a
Nothing Map String Namespace
env' QName
a, AttValue
v)) [Attribute]
attrs)
                           ((Content i -> Content i) -> [Content i] -> [Content i]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Namespace -> Map String Namespace -> Content i -> Content i
walkContent Maybe Namespace
def' Map String Namespace
env') [Content i]
conts)
        where def' :: Maybe Namespace
def' = (Maybe Namespace -> Maybe Namespace -> Maybe Namespace)
-> Maybe Namespace -> [Maybe Namespace] -> Maybe Namespace
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe Namespace -> Maybe Namespace -> Maybe Namespace
forall a b. a -> b -> a
const Maybe Namespace
def  -- like "maybe def head", but for lists
                           ((Attribute -> Maybe Namespace) -> [Attribute] -> [Maybe Namespace]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Maybe Namespace
defNamespace ((String -> Bool) -> [Attribute] -> [Attribute]
matching (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"xmlns") [Attribute]
attrs))
              env' :: Map String Namespace
env' = (Namespace -> Map String Namespace -> Map String Namespace)
-> Map String Namespace -> [Namespace] -> Map String Namespace
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Namespace -> Map String Namespace -> Map String Namespace
augmentNamespaceEnv Map String Namespace
env
                           ((Attribute -> Namespace) -> [Attribute] -> [Namespace]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Namespace
mkNamespace
                                ((String -> Bool) -> [Attribute] -> [Attribute]
matching (String
"xmlns:"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [Attribute]
attrs))
              defNamespace :: Attribute -> Maybe Namespace
              defNamespace :: Attribute -> Maybe Namespace
defNamespace (QName
_ {-N "xmlns"-}, AttValue
atv)
                      | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (AttValue -> String
forall a. Show a => a -> String
show AttValue
atv) = Maybe Namespace
forall a. Maybe a
Nothing
                      | Bool
otherwise       = Namespace -> Maybe Namespace
forall a. a -> Maybe a
Just Namespace
nullNamespace{nsURI :: String
nsURI=AttValue -> String
forall a. Show a => a -> String
show AttValue
atv}
              mkNamespace :: Attribute -> Namespace
              mkNamespace :: Attribute -> Namespace
mkNamespace (N String
n, AttValue
atv)  = let (String
_,Char
':':String
nm) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
':') String
n in 
                                        Namespace :: String -> String -> Namespace
Namespace{nsPrefix :: String
nsPrefix=String
nm,nsURI :: String
nsURI=AttValue -> String
forall a. Show a => a -> String
show AttValue
atv}
              matching :: (String->Bool) -> [Attribute] -> [Attribute]
              matching :: (String -> Bool) -> [Attribute] -> [Attribute]
matching String -> Bool
p = (Attribute -> Bool) -> [Attribute] -> [Attribute]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
p (String -> Bool) -> (Attribute -> String) -> Attribute -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
printableName (QName -> String) -> (Attribute -> QName) -> Attribute -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> QName
forall a b. (a, b) -> a
fst)
    --
    walkContent :: Maybe Namespace -> Map String Namespace -> Content i -> Content i
walkContent Maybe Namespace
def Map String Namespace
env (CElem Element i
e i
i) = Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (Maybe Namespace -> Map String Namespace -> Element i -> Element i
walkElem Maybe Namespace
def Map String Namespace
env Element i
e) i
i
    walkContent Maybe Namespace
_   Map String Namespace
_   Content i
content     = Content i
content

    -- Notes: we DO NOT CHECK some of the Namespace well-formedness conditions:
    --        Prefix Declared
    --        No Prefix Undeclaring
    --        Attributes Unique
    -- The functions defNamespace and mkNamespace are partial - they do not
    -- handle the QN case - but this is OK because they are only called from
    -- def' and env', which check the precondition