    {-# 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.Maybe (fromMaybe)
    import Data.List (isPrefixOf)

    -- | The null Namespace (no prefix, no URI).
    nullNamespace :: Namespace
    nullNamespace :: Namespace
    nullNamespace  = 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 a. [a] -> 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 a. Eq a => a -> [a] -> 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 -> Maybe Namespace -> Namespace
    forall a. a -> Maybe a -> a
    fromMaybe Namespace
    nullNamespace {nsPrefix=pre}
                                          (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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Namespace -> String
    nsURI Namespace
    ns) = Namespace -> String -> QName
    QN (Namespace -> Maybe Namespace -> Namespace
    forall a. a -> Maybe a -> a
    fromMaybe Namespace
    ns (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 a. Eq a => a -> [a] -> 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 -> Maybe Namespace -> Namespace
    forall a. a -> Maybe a -> a
    fromMaybe Namespace
    nullNamespace{nsPrefix=pre}
                                              (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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Namespace -> String
    nsURI Namespace
    ns) = Namespace -> String -> QName
    QN (Namespace -> Maybe Namespace -> Namespace
    forall a. a -> Maybe a -> a
    fromMaybe Namespace
    ns (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{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{nsPrefix :: String
    nsPrefix=String
    "xml"
                                      ,nsURI :: String
    nsURI=String
    "http://www.w3.org/XML/1998/namespace"}
          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 :: forall i.
    (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 ((DocTypeDecl -> DocTypeDecl)
    -> Maybe DocTypeDecl -> Maybe DocTypeDecl
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap 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)
                          -- like "maybe def head", but for lists
            where def' :: Maybe Namespace
    def' = (Attribute -> Maybe Namespace -> Maybe Namespace)
    -> Maybe Namespace -> [Attribute] -> Maybe Namespace
    forall a b. (a -> b -> b) -> b -> [a] -> b
    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 -> Maybe Namespace -> Maybe Namespace)
    -> (Attribute -> Maybe Namespace)
    -> Attribute
    -> Maybe Namespace
    -> Maybe Namespace
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Attribute -> Maybe Namespace
    defNamespace) Maybe Namespace
    def
                         ((String -> Bool) -> [Attribute] -> [Attribute]
    matching (String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==String
    "xmlns") [Attribute]
    attrs)
                  env' :: Map String Namespace
    env' = (Attribute -> Map String Namespace -> Map String Namespace)
    -> Map String Namespace -> [Attribute] -> Map String Namespace
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (Namespace -> Map String Namespace -> Map String Namespace
    augmentNamespaceEnv (Namespace -> Map String Namespace -> Map String Namespace)
    -> (Attribute -> Namespace)
    -> Attribute
    -> Map String Namespace
    -> Map String Namespace
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Attribute -> Namespace
    mkNamespace) Map String Namespace
    env
                         ((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 a. [a] -> 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=show 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{nsPrefix :: String
    nsPrefix=String
    nm,nsURI :: String
    nsURI=AttValue -> String
    forall a. Show a => a -> String
    show AttValue
    atv}
                  mkNamespace (q :: QName
    q@(QN (Namespace{ nsURI :: Namespace -> String
    nsURI=String
    "" }) String
    n), AttValue
    atv)  =
                                            Namespace{nsPrefix :: String
    nsPrefix=String
    n,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