{-# 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="", nsURI :: String
nsURI="" }

-- | 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 n :: 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 _)     = Maybe Namespace
forall a. Maybe a
Nothing
namespaceName (QN ns :: Namespace
ns _) = 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 n :: String
n)     = String
n
localName (QN _ n :: 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 n :: String
n)     = String
n
printableName (QN ns :: Namespace
ns n :: 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 -> 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 def :: Maybe Namespace
def env :: Map String Namespace
env (N n :: String
n)
        | ':'Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
n      = let (pre :: String
pre,':':nm :: 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
/=':') 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 d :: Namespace
d <- Maybe Namespace
def   = Namespace -> String -> QName
QN Namespace
d String
n
        | Bool
otherwise       = String -> QName
N String
n
qualify _ env :: Map String Namespace
env qn :: QName
qn@(QN ns :: Namespace
ns 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

-- | '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 _ _ (QN _ n :: String
n) = String -> QName
N String
n
deQualify _ _ (N 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 Nothing    env :: Map String Namespace
env  qn :: 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 def :: Namespace
def) env :: Map String Namespace
env (N n :: String
n)
        | ':'Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`String
n      = let (pre :: String
pre,':':nm :: 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
/=':') 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 def :: Namespace
def) env :: Map String Namespace
env qn :: QName
qn@(QN ns :: Namespace
ns n :: 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 "xmlns" Namespace :: String -> String -> Namespace
Namespace{nsPrefix :: String
nsPrefix="xmlns"
                                  ,nsURI :: String
nsURI="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 "xml"   Namespace :: String -> String -> Namespace
Namespace{nsPrefix :: String
nsPrefix="xml"
                                  ,nsURI :: String
nsURI="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 ns :: Namespace
ns env :: 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 qualify :: Maybe Namespace -> Map String Namespace -> QName -> QName
qualify (Document prolog :: Prolog
prolog entities :: SymTab EntityDef
entities elm :: Element i
elm misc :: [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 xml :: Maybe XMLDecl
xml misc0 :: [Misc]
misc0 mDTD :: Maybe DocTypeDecl
mDTD misc1 :: [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 qn :: QName
qn ext :: Maybe ExternalID
ext mds :: [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 ed :: ElementDecl
ed)          = ElementDecl -> MarkupDecl
Element (ElementDecl -> ElementDecl
walkED ElementDecl
ed)
    walkMD (AttList ald :: AttListDecl
ald)         = AttListDecl -> MarkupDecl
AttList (AttListDecl -> AttListDecl
walkALD AttListDecl
ald)
    walkMD md :: MarkupDecl
md                    = MarkupDecl
md
    --
    walkED :: ElementDecl -> ElementDecl
walkED (ElementDecl qn :: QName
qn cs :: ContentSpec
cs)   = QName -> ContentSpec -> ElementDecl
ElementDecl (QName -> QName
qualifyInDTD QName
qn) (ContentSpec -> ContentSpec
walkCS ContentSpec
cs)
    --
    walkCS :: ContentSpec -> ContentSpec
walkCS (ContentSpec cp :: CP
cp)      = CP -> ContentSpec
ContentSpec (CP -> CP
walkCP CP
cp)
    walkCS (Mixed m :: Mixed
m)             = Mixed -> ContentSpec
Mixed (Mixed -> Mixed
walkM Mixed
m)
    walkCS cs :: ContentSpec
cs                    = ContentSpec
cs
    --
    walkCP :: CP -> CP
walkCP (TagName qn :: QName
qn m :: Modifier
m)        = QName -> Modifier -> CP
TagName (QName -> QName
qualifyInDTD QName
qn) Modifier
m
    walkCP cp :: CP
cp                    = CP
cp
    --
    walkM :: Mixed -> Mixed
walkM (PCDATAplus qns :: [QName]
qns)       = [QName] -> Mixed
PCDATAplus ((QName -> QName) -> [QName] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map QName -> QName
qualifyInDTD [QName]
qns)
    walkM PCDATA                 = Mixed
PCDATA
    --
    walkALD :: AttListDecl -> AttListDecl
walkALD (AttListDecl qn :: QName
qn ads :: [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 qn :: QName
qn at :: AttType
at dd :: 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 def :: Maybe Namespace
def env :: Map String Namespace
env (Elem qn :: QName
qn attrs :: [Attribute]
attrs conts :: [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 (\ (a :: QName
a,v :: 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
=="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 ("xmlns:"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [Attribute]
attrs))
              defNamespace :: Attribute -> Maybe Namespace
              defNamespace :: Attribute -> Maybe Namespace
defNamespace (_ {-N "xmlns"-}, atv :: 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 n :: String
n, atv :: AttValue
atv)  = let (_,':':nm :: 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
/=':') 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 p :: 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 def :: Maybe Namespace
def env :: Map String Namespace
env (CElem e :: Element i
e i :: 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 _   _   content :: 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