--------------------------------------------------------------------
-- |
-- 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)