module Text.ParserCombinators.Parsec.XML
(XMLParser
,anyContent
,content
,element
,text
,namedElement
,namedElementWithAttrs
,stringElement
,recurse
,recurseElements
) where
import Text.XML.HaXml.Posn
import qualified Text.XML.HaXml.Pretty as Pretty
import Text.XML.HaXml.Types
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
type XMLParser a = GenParser (Content Posn) () a
getPosn :: Content Posn -> SourcePos
getPosn cont = let
posn = case cont of
CElem _ p -> p
CString _ _ p -> p
CRef _ p -> p
CMisc _ p -> p
in newPos (posnFilename posn) (posnLine posn) (posnColumn posn)
classifyContent :: Content a -> String
classifyContent cont = (case cont of
CElem _ _ -> "element"
CString _ _ _ -> "string"
CRef _ _ -> "reference"
CMisc _ _ -> "misc") ++ "(" ++ (show $ Pretty.content cont) ++ ")"
anyContent :: XMLParser (Content Posn)
anyContent = content (Just)
content :: (Content Posn -> Maybe a) -> XMLParser a
content f = token classifyContent getPosn f
element :: XMLParser (Element Posn)
element = content (\cont -> case cont of
CElem el _ -> Just el
_ -> Nothing)
<?> "element"
text :: XMLParser String
text = content (\cont -> case cont of
CString _ str _ -> Just str
_ -> Nothing)
<?> "text-node"
namedElementWithAttrs :: String -> XMLParser ([Attribute],[Content Posn])
namedElementWithAttrs name = content (\cont -> case cont of
CElem (Elem ename attr conts) _
| ename == name -> Just (attr,conts)
| otherwise -> Nothing
_ -> Nothing)
<?> "element \""++name++"\""
namedElement :: String -> XMLParser [Content Posn]
namedElement name = namedElementWithAttrs name >>= return.snd
stringElement :: String -> XMLParser String
stringElement name = namedElement name >>= recurse (option "" text)
recurseElements :: XMLParser a -> [Content Posn] -> XMLParser a
recurseElements p conts = recurse p [ el | el@(CElem _ _) <- conts ]
recurse :: XMLParser a -> [Content Posn] -> XMLParser a
recurse p conts = do
inp <- getInput
setInput conts
res <- p
setInput inp
return res