Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 151 lines (127 sloc) 3.699 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
module RSXP (
    XMLAST (Element, Body, Comment)
  , parseXML'
  , parseXML
  , getAllBodies
  , getBodiesByName
  , getAllElements
  , getElementsByName
  , getElementsByPath
) where

import Text.ParserCombinators.Parsec

data XMLAST =
    Element Name [Attribute] [XMLAST]
  | Body String
  | Comment String
  | Schema String
  | CouldNotParse String
  deriving Show

type Name = String
type Attribute = (Key, Value)
type Key = String
type Value = String

parseXML' :: String -> [XMLAST]
parseXML' str =
  f ast where
      ast = parse ((many innerXML)) "" str
      f (Right x) = x
      f (Left x) = [CouldNotParse (show x)]

parseXML :: String -> XMLAST
parseXML str =
  f ast where
      ast = parse (spaces >> xmlParser) "" str
      f (Right x) = x
      f (Left x) = CouldNotParse (show x)
      
xmlParser :: Parser XMLAST
xmlParser =
  try withoutExplictCloseTag <|> withExplicitCloseTag


withExplicitCloseTag :: Parser XMLAST
withExplicitCloseTag =
  do
    (name, attr) <- openTag
    innerXML <- many innerXML
    closeTag name
    return (Element name attr innerXML)

innerXML = comment <|> schema <|> xmlParser <|> parseBody

parseBody = fmap Body $ many1 $ noneOf "<>"

schema :: Parser XMLAST
schema =
  do
    try $ string "<!"
    body <- manyTill anyChar (string ">")
    return (Schema body)

comment :: Parser XMLAST
comment =
  do
    try $ string "<!--"
    body <- manyTill anyChar (string "-->")
    return (Comment body)

openTag :: Parser (String, [(String,String)])
openTag =
  do
    try $ char '<' >> notFollowedBy (char '/')
    tag <- many (letter <|> digit)
    spaces
    a <- try (many keyValue)
    char '>'
    return (tag, a)

closeTag :: String -> Parser ()
closeTag str =
  do
    try $ string "</"
    spaces
    string str
    spaces
    char '>'
    return ()

withoutExplictCloseTag :: Parser XMLAST
withoutExplictCloseTag =
  do
    try $ char '<' >> notFollowedBy (char '/')
    name <- many (letter <|> digit)
    spaces
    a <- try (many keyValue)
    spaces
    string "/>"
    return (Element name a [])

keyValue :: Parser (String, String)
keyValue =
  do
    key <- many1 (letter <|> digit <|> char '-')
    spaces
    char '='
    spaces
    value <- quotedString
    spaces
    return (key, value)

quotedString :: Parser String
quotedString = do
  q <- (try (char '"')) <|> char '\''
  value <- fmap concat $ many
    $ many1 (noneOf ['\\', q])
      <|> try (string ['\\', q])
      <|> try (string "\\")
  char q
  return value


getAllElements :: XMLAST -> [(XMLAST, String, XMLAST)]
getAllElements ast = getAllElements' ast "" ast
getAllElements' pe pp element@(Element n a es) = concat $ map (getAllElements' element (pp ++ "/" ++ n)) es
getAllElements' pe pp x = [(pe, pp, x)]

getElementsByName :: String -> XMLAST -> [(XMLAST, String, XMLAST)]
getElementsByName str ast = filter (\e -> f e) (getAllElements ast) where
                  f ((Element n _ _), _, _) = n == str
                  f _ = False

getElementsByPath :: String -> XMLAST -> [(XMLAST, String, XMLAST)]
getElementsByPath str ast = filter (\e -> f e) (getAllElements ast) where
                  f (_ , p, _) = p == str


getAllBodies :: XMLAST -> [(String, String)]
getAllBodies = getAllBodies' "" where
  getAllBodies' :: String -> XMLAST -> [(String, String)]
  getAllBodies' p (Body str) = [(p, str)]
  getAllBodies' p (Element n a es) =
               let v2 = concat $ map (getAllBodies' (fixUp p n)) es
                   fixUp x y = x ++ "/" ++ y
               in v2
  getAllBodies' p _ = []

getBodiesByName :: String -> XMLAST -> [String]
getBodiesByName name xmlast= map snd $ filter (\(n,v) -> n == name) (getAllBodies xmlast)
Something went wrong with that request. Please try again.