XMLParser 0.1.0.5 → 0.1.0.6
raw patch · 5 files changed
+201/−11 lines, 5 files
Files
- Text/XMLParser.hs +0/−10
- XMLParser.cabal +5/−1
- src/Text/XMLParser.hs +10/−0
- src/Text/XMLParser/Util.hs +34/−0
- src/Text/XMLParser/XMLParser.hs +152/−0
− Text/XMLParser.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-} --module Text.XMLParser (- module Text.XMLParser.Util- ,module Text.XMLParser.XMLParser-) where--import Text.XMLParser.Util-import Text.XMLParser.XMLParser
XMLParser.cabal view
@@ -1,5 +1,5 @@ name: XMLParser-version: 0.1.0.5+version: 0.1.0.6 cabal-version: >=1.10 build-type: Simple license: GPL-3@@ -20,6 +20,10 @@ location: http://github.com/xpika/XMLParser.git library+ hs-source-dirs: src+ other-modules:+ Text.XMLParser.XMLParser+ , Text.XMLParser.Util exposed-modules: Text.XMLParser build-depends:
+ src/Text/XMLParser.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-} ++module Text.XMLParser (+ module Text.XMLParser.Util+ ,module Text.XMLParser.XMLParser+) where++import Text.XMLParser.Util+import Text.XMLParser.XMLParser
+ src/Text/XMLParser/Util.hs view
@@ -0,0 +1,34 @@+module Text.XMLParser.Util (++ getTagOfNameChildren+,getTagsByName+,getNonEmptyTagOfNameChildren+,getNonEmptyTagsByName+,getNonEmptyAttributeByName+) where ++import Text.XMLParser.XMLParser+import Data.Maybe++makeNonEmpty [] = Nothing+makeNonEmpty xs@(_:_) = Just xs++getTagName (Tag _ str _) = Just str+getTagName _ = Nothing++getTagText (TagString a) = Just a+getTagText _ = Nothing++getTagChildText (Tag _ _ (Just xs)) = catMaybes $ map getTagText xs+getTagChildText _ = []++getTagOfNameChildren str (Tag _ str' (Just xs)) + | str == str' = Just xs+ | otherwise = Nothing++getTagsByName str xs = filter (maybe False (==str) . getTagName) xs++getNonEmptyTagOfNameChildren str tag = getTagOfNameChildren str tag >>= makeNonEmpty+getNonEmptyTagsByName name xs = makeNonEmpty $ getTagsByName name xs +getNonEmptyAttributeByName attr (Tag attrs _ _) = lookup attr attrs +
+ src/Text/XMLParser/XMLParser.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts #-} ++module Text.XMLParser.XMLParser (+ xmlParser+ ,parseXML+ ,showXML+ ,Tag(..)+) where++import Text.ParserCombinators.Parsec +import Control.Monad+import Data.Monoid+import Data.Either+import Data.List+import Data.Char++keys = map fst+escapeCodes = + [("gt",'>')+ ,("lt",'<')+ ,("amp",'&')+ ,("quot",'\"')+ ,("apos",'\'')]+++data Tag = Tag [(String,String)] String (Maybe [Tag])+ | TagString String+ | TagCData String+ deriving (Show,Eq)+ +spaceOut p = between (many space) (many space) p ++attr = do+ attr <- spaceOut $ many1 (satisfy (liftM2 ((not.).(||)) isSpace (`elem` "=<>")))+ string "="+ value <- spaceOut $ between (string "\"") (string "\"") (many1 (noneOf "\"")) + <|> between (string "'") (string "'") (many1 (noneOf "'")) + return (attr,value)+ ++many1Till p e = do+ notFollowedBy e+ x <- p+ xs <- manyTill p (try e)+ return (x:xs)++many1Till' p e = do+ xs <- many1Till p (lookAhead e)+ y <- e+ return (xs,y)++openTag = do+ string "<"+ skipMany space+ many1Till' anyChar $ do+ attrs <- spaceOut $ try (many attr)+ string ">"+ return attrs++closeTag str = do+ x <- string "</"+ y <- string str+ z <- (string ">")+ return y++sparse p t = parse p "" t+sameConstructor (Left _) (Left _) = True+sameConstructor (Right _) (Right _) = True+sameConstructor _ _ = False+ +tagWithoutContent = do+ (x,a) <- tagWithoutContent'+ return (Tag a x Nothing)++ +tagWithoutContent' = do + string "<"+ skipMany space+ many1Till' anyChar $ do+ attrs <- spaceOut $ try (many (try attr))+ string "/>"+ return attrs++groupEithers :: [Either a b] -> [Either [a] [b]]+groupEithers xs = map (\xs@(x:_) -> either (const (Left (lefts xs))) (const (Right (rights xs))) x) (groupBy sameConstructor xs)++closedTag = do+ (x,a) <- openTag+ let cd = fmap Right cdata'+ let frag = fmap Left fragmentParse+ let text = fmap Right (noneOf "><" >>= return . (:[]) ) + y <- manyTill ( try cd <|> try frag <|> text) (try $ closeTag x)+ let s = map (either head ( TagString . replaceEntities . concat )) (groupEithers y)+ return (Tag a x (Just s))+ +fragmentParse = do+ b <- closedTag + return b++xmlParser = do + x <- try tagWithoutContent <|> fragmentParse + eof + return x+ +showAttribute (x,y) = x++"="++"\""++y++"\""+showAttributes atts = concat $ intersperse " " $ map showAttribute atts ++showXML (Tag attr str inner) = case inner of + Nothing -> "<"++str++attr''++"/>"+ (Just xs) -> "<"++str++attr''++">"++(concatMap showXML xs)++"</"++str++">"+ where attr'' = if null attr' then attr'+ else " "++attr'+ attr' = showAttributes attr+showXML (TagString str) = str+showXML (TagCData str) =str++escapeCode = do+ char '&'+ x <- choice (map (\(k,v) -> string k >> return v ) escapeCodes)+ char ';'+ return [x]++w = parse escapeCode "" "<"++cdata = do+ x <- cdata'+ return (TagCData x) +cdata' = do+ string "<![CDATA["+ many1Till anyChar (string "]]>")+ +q = parse cdata "" "<![CDATA[ hi ]]>"++replaceEntities = (\(Right x) -> x) . parse (replaceParser' escapeCode) ""++replaceParser parser = (\(Right x) ->x) . parse (replaceParser' parser) "" ++replaceParser' parser = replaceParser'' parser (anyChar >>=(return . (:[])))++replaceParser'' parser p2 = do + xs <- many (try parser <|> p2 )+ return (concat xs)+++parseXML = parse xmlParser ""++main = do + let str = "<one green=\"blue\"> < five <two> <![CDATA[ hello </two> ]]> </two> </one>"+ print str+ let rs = map (parse xmlParser "") [str,"<single/>","<nocont></nocont>"]+ mapM_ (either (const (print "fail")) (\x -> mapM_ putStrLn [showXML x,show x] )) rs