--------------------------------------------------------------------
-- |
-- 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 :: forall s. XmlSource s => s -> Maybe Element
parseXMLDoc s
xs  = [Content] -> Maybe Element
strip (s -> [Content]
forall s. XmlSource s => s -> [Content]
parseXML s
xs)
  where strip :: [Content] -> Maybe Element
strip [Content]
cs = case [Content] -> [Element]
onlyElems [Content]
cs of
                    Element
e : [Element]
es
                      | String
"?xml" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` QName -> String
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
                    [Element]
_ -> Maybe Element
forall a. Maybe a
Nothing

-- | parseXML to a list of content chunks
parseXML :: XmlSource s => s -> [Content]
parseXML :: forall s. XmlSource s => 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 [Token]
ts    = let ([Content]
es,[QName]
_,[Token]
ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
nodes ([],Maybe String
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 NSInfo
ns [QName]
ps (TokCRef String
ref : [Token]
ts) =
  let ([Content]
es,[QName]
qs,[Token]
ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
nodes NSInfo
ns [QName]
ps [Token]
ts
  in (String -> Content
CRef String
ref Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
es, [QName]
qs, [Token]
ts1)

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

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

nodes NSInfo
cur_info [QName]
ps (TokStart Line
p QName
t [Attr]
as Bool
empty : [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 a b. (a -> b -> b) -> b -> [a] -> b
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 { 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
                           }

  ([Content]
children,([Content]
siblings,[QName]
open,[Token]
toks))
    | Bool
empty     = ([], NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
nodes NSInfo
cur_info [QName]
ps [Token]
ts)
    | Bool
otherwise = let ([Content]
es1,[QName]
qs1,[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
                        QName
_ : [QName]
qs3 -> ([],[QName]
qs3,[Token]
ts1))

nodes NSInfo
ns [QName]
ps (TokEnd Line
p QName
t : [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
                                  ([QName]
as,QName
_:[QName]
_) -> ([],[QName]
as,[Token]
ts)
                                  -- Unknown closing tag. Insert as text.
                                  ([QName]
_,[]) ->
                                    let ([Content]
es,[QName]
qs,[Token]
ts1) = NSInfo -> [QName] -> [Token] -> ([Content], [QName], [Token])
nodes NSInfo
ns [QName]
ps [Token]
ts
                                    in (CData -> Content
Text CData {
                                               cdLine :: Maybe Line
cdLine = Line -> Maybe Line
forall a. a -> Maybe a
Just Line
p,
                                               cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataText,
                                               cdData :: String
cdData = QName -> String -> String
tagEnd QName
t String
""
                                              } Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
es,[QName]
qs, [Token]
ts1)

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


annotName :: NSInfo -> QName -> QName
annotName :: NSInfo -> QName -> QName
annotName ([(String, String)]
namespaces,Maybe String
def_ns) QName
n =
  QName
n { qURI = maybe def_ns (`lookup` namespaces) (qPrefix n) }

annotAttr :: NSInfo -> Attr -> Attr
annotAttr :: NSInfo -> Attr -> Attr
annotAttr NSInfo
ns a :: Attr
a@(Attr { attrKey :: Attr -> QName
attrKey = QName
k}) =
  case (QName -> Maybe String
qPrefix QName
k, QName -> String
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>.
    (Maybe String
Nothing, String
_)      -> Attr
a
    (Maybe String, String)
_                 -> Attr
a { attrKey = annotName ns k }

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