    --------------------------------------------------------------------
    -- |
    -- Module    : Text.XML.Light.Input
    -- Copyright : (c) Galois, Inc. 2007
    -- License   : BSD3
    --
    -- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
    -- Stability : provisional
    -- Portability: portable
    --
    -- Lightweight XML parsing
    --

    module Text.XML.Light.Input (parseXML,parseXMLDoc) where

    import Text.XML.Light.Lexer
    import Text.XML.Light.Types
    import Text.XML.Light.Proc
    import Text.XML.Light.Output(tagEnd)

    import Data.List(isPrefixOf)

    -- | parseXMLDoc, parse a XMLl document to maybe an element
    parseXMLDoc  :: XmlSource s => s -> Maybe Element
    parseXMLDoc :: s -> Maybe Element
    parseXMLDoc xs :: s
    xs  = [Content] -> Maybe Element
    strip (s -> [Content]
    forall s. XmlSource s => s -> [Content]
    parseXML s
    xs)
      where strip :: [Content] -> Maybe Element
    strip cs :: [Content]
    cs = case [Content] -> [Element]
    onlyElems [Content]
    cs of
                        e :: Element
    e : es :: [Element]
    es
                          | "?xml" [Char] -> [Char] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` QName -> [Char]
    qName (Element -> QName
    elName Element
    e)
                              -> [Content] -> Maybe Element
    strip ((Element -> Content) -> [Element] -> [Content]
    forall a b. (a -> b) -> [a] -> [b]
    map Element -> Content
    Elem [Element]
    es)
                          | Bool
    otherwise -> Element -> Maybe Element
    forall a. a -> Maybe a
    Just Element
    e
                        _ -> Maybe Element
    forall a. Maybe a
    Nothing

    -- | parseXML to a list of content chunks
    parseXML :: XmlSource s => s -> [Content]
    parseXML :: s -> [Content]
    parseXML  = [Token] -> [Content]
    parse ([Token] -> [Content]) -> (s -> [Token]) -> s -> [Content]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . s -> [Token]
    forall source. XmlSource source => source -> [Token]
    tokens

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

    parse      :: [Token] -> [Content]
    parse :: [Token] -> [Content]
    parse []    = []
    parse ts :: [Token]
    ts    = let (es :: [Content]
    es,_,ts1 :: [Token]
    ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes ([],Maybe [Char]
    forall a. Maybe a
    Nothing) [] [Token]
    ts
                  in [Content]
    es [Content] -> [Content] -> [Content]
    forall a. [a] -> [a] -> [a]
    ++ [Token] -> [Content]
    parse [Token]
    ts1

    -- Information about namespaces.
    -- The first component is a map that associates prefixes to URIs,
    -- the second is the URI for the default namespace, if one was provided.
    type NSInfo = ([(String,String)],Maybe String)

    nodes :: NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])

    nodes :: NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes ns :: NSInfo
    ns ps :: [QName]
    ps (TokCRef ref :: [Char]
    ref : ts :: [Token]
    ts) =
      let (es :: [Content]
    es,qs :: [QName]
    qs,ts1 :: [Token]
    ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes NSInfo
    ns [QName]
    ps [Token]
    ts
      in ([Char] -> Content
    CRef [Char]
    ref Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    : [Content]
    es, [QName]
    qs, [Token]
    ts1)

    nodes ns :: NSInfo
    ns ps :: [QName]
    ps (TokText txt :: CData
    txt : ts :: [Token]
    ts) =
      let (es :: [Content]
    es,qs :: [QName]
    qs,ts1 :: [Token]
    ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes NSInfo
    ns [QName]
    ps [Token]
    ts
          (more :: [Char]
    more,es1 :: [Content]
    es1)  = case [Content]
    es of
                          Text cd :: CData
    cd : es1' :: [Content]
    es1'
                            | CData -> CDataKind
    cdVerbatim CData
    cd CDataKind -> CDataKind -> Bool
    forall a. Eq a => a -> a -> Bool
    == CData -> CDataKind
    cdVerbatim CData
    txt -> (CData -> [Char]
    cdData CData
    cd,[Content]
    es1')
                          _                                   -> ([],[Content]
    es)

      in (CData -> Content
    Text CData
    txt { cdData :: [Char]
    cdData = CData -> [Char]
    cdData CData
    txt [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    more } Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    : [Content]
    es1, [QName]
    qs, [Token]
    ts1)

    nodes cur_info :: NSInfo
    cur_info ps :: [QName]
    ps (TokStart p :: Line
    p t :: QName
    t as :: [Attr]
    as empty :: Bool
    empty : ts :: [Token]
    ts) = (Content
    node Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    : [Content]
    siblings, [QName]
    open, [Token]
    toks)
      where
      new_name :: QName
    new_name  = NSInfo -> QName -> QName
    annotName NSInfo
    new_info QName
    t
      new_info :: NSInfo
    new_info  = (Attr -> NSInfo -> NSInfo) -> NSInfo -> [Attr] -> NSInfo
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Attr -> NSInfo -> NSInfo
    addNS NSInfo
    cur_info [Attr]
    as
      node :: Content
    node      = Element -> Content
    Elem Element :: QName -> [Attr] -> [Content] -> Maybe Line -> Element
    Element { elLine :: Maybe Line
    elLine    = Line -> Maybe Line
    forall a. a -> Maybe a
    Just Line
    p
                               , elName :: QName
    elName    = QName
    new_name
                               , elAttribs :: [Attr]
    elAttribs = (Attr -> Attr) -> [Attr] -> [Attr]
    forall a b. (a -> b) -> [a] -> [b]
    map (NSInfo -> Attr -> Attr
    annotAttr NSInfo
    new_info) [Attr]
    as
                               , elContent :: [Content]
    elContent = [Content]
    children
                               }

      (children :: [Content]
    children,(siblings :: [Content]
    siblings,open :: [QName]
    open,toks :: [Token]
    toks))
        | Bool
    empty     = ([], NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes NSInfo
    cur_info [QName]
    ps [Token]
    ts)
        | Bool
    otherwise = let (es1 :: [Content]
    es1,qs1 :: [QName]
    qs1,ts1 :: [Token]
    ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes NSInfo
    new_info (QName
    new_nameQName -> [QName] -> [QName]
    forall a. a -> [a] -> [a]
    :[QName]
    ps) [Token]
    ts
                      in ([Content]
    es1,
                          case [QName]
    qs1 of
                            [] -> NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes NSInfo
    cur_info [QName]
    ps [Token]
    ts1
                            _ : qs3 :: [QName]
    qs3 -> ([],[QName]
    qs3,[Token]
    ts1))

    nodes ns :: NSInfo
    ns ps :: [QName]
    ps (TokEnd p :: Line
    p t :: QName
    t : ts :: [Token]
    ts)   = let t1 :: QName
    t1 = NSInfo -> QName -> QName
    annotName NSInfo
    ns QName
    t
                                    in case (QName -> Bool) -> [QName] -> ([QName], [QName])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (QName
    t1 QName -> QName -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) [QName]
    ps of
                                      (as :: [QName]
    as,_:_) -> ([],[QName]
    as,[Token]
    ts)
                                      -- Unknown closing tag. Insert as text.
                                      (_,[]) ->
                                        let (es :: [Content]
    es,qs :: [QName]
    qs,ts1 :: [Token]
    ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
    nodes NSInfo
    ns [QName]
    ps [Token]
    ts
                                        in (CData -> Content
    Text CData :: CDataKind -> [Char] -> Maybe Line -> CData
    CData {
                                                   cdLine :: Maybe Line
    cdLine = Line -> Maybe Line
    forall a. a -> Maybe a
    Just Line
    p,
                                                   cdVerbatim :: CDataKind
    cdVerbatim = CDataKind
    CDataText,
                                                   cdData :: [Char]
    cdData = QName -> [Char] -> [Char]
    tagEnd QName
    t ""
                                                  } Content -> [Content] -> [Content]
    forall a. a -> [a] -> [a]
    : [Content]
    es,[QName]
    qs, [Token]
    ts1)

    nodes _ ps :: [QName]
    ps []                 = ([],[QName]
    ps,[])

    annotName :: NSInfo -> QName -> QName
    annotName :: NSInfo -> QName -> QName
    annotName (namespaces :: [([Char], [Char])]
    namespaces,def_ns :: Maybe [Char]
    def_ns) n :: QName
    n =
      QName
    n { qURI :: Maybe [Char]
    qURI = Maybe [Char]
    -> ([Char] -> Maybe [Char]) -> Maybe [Char] -> Maybe [Char]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Maybe [Char]
    def_ns ([Char] -> [([Char], [Char])] -> Maybe [Char]
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    `lookup` [([Char], [Char])]
    namespaces) (QName -> Maybe [Char]
    qPrefix QName
    n) }

    annotAttr :: NSInfo -> Attr -> Attr
    annotAttr :: NSInfo -> Attr -> Attr
    annotAttr ns :: NSInfo
    ns a :: Attr
    a@(Attr { attrKey :: Attr -> QName
    attrKey = QName
    k}) =
      case (QName -> Maybe [Char]
    qPrefix QName
    k, QName -> [Char]
    qName QName
    k) of
        -- Do not apply the default name-space to unqualified
        -- attributes.  See Section 6.2 of <http://www.w3.org/TR/REC-xml-names>.
        (Nothing, _)      -> Attr
    a
        _                 -> Attr
    a { attrKey :: QName
    attrKey = NSInfo -> QName -> QName
    annotName NSInfo
    ns QName
    k }

    addNS :: Attr -> NSInfo -> NSInfo
    addNS :: Attr -> NSInfo -> NSInfo
    addNS (Attr { attrKey :: Attr -> QName
    attrKey = QName
    key, attrVal :: Attr -> [Char]
    attrVal = [Char]
    val }) (ns :: [([Char], [Char])]
    ns,def :: Maybe [Char]
    def) =
      case (QName -> Maybe [Char]
    qPrefix QName
    key, QName -> [Char]
    qName QName
    key) of
        (Nothing,"xmlns") -> ([([Char], [Char])]
    ns, if [Char] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Char]
    val then Maybe [Char]
    forall a. Maybe a
    Nothing else [Char] -> Maybe [Char]
    forall a. a -> Maybe a
    Just [Char]
    val)
        (Just "xmlns", k :: [Char]
    k) -> (([Char]
    k, [Char]
    val) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
    forall a. a -> [a] -> [a]
    : [([Char], [Char])]
    ns, Maybe [Char]
    def)
        _                 -> ([([Char], [Char])]
    ns,Maybe [Char]
    def)