XPathTrie.hs

import Data.Function
import Data.List
import Data.Maybe
import Control.Monad

data XmlElement =
      RegularNode String [XmlElement]
    | EndNode String
    | TextNode String
    deriving (Show, Eq)

getTagName :: XmlElement -> String
getTagName e = case e of
    RegularNode n _ -> n
    EndNode n       -> n
    TextNode _      -> "#text"

getChildren :: XmlElement -> [XmlElement]
getChildren e = case e of
    RegularNode _ n -> n
    EndNode _       -> []
    TextNode _      -> []

data Trie a =
      RootTrie [Trie a]
    | NodeTrie a [Trie a]
    | EmptyTrie
    deriving (Show, Eq)

document :: XmlElement
document = RegularNode "/" [
      RegularNode "a" [
        EndNode "B"
      , RegularNode "b" [
          RegularNode "C" [
            RegularNode "d" [
              TextNode "coucou"
            , EndNode "E"
            , RegularNode "f" [EndNode "g"]
            ]
          ]
        ]
      ]
    , RegularNode "A" []
    ]

weakXpaths :: [String]
weakXpaths = [
      "A/b/C/d"
    , "d/m/a"
    , "a/B"
    , "A/b/C/d/e/f/g"
    , "a/B/E/f"
    , "a/B/e"
    , "A"
    ]

strongXpaths :: Trie String
strongXpaths = toTrie weakXpaths

toTrie :: [String] -> Trie String
toTrie = toTrieRoot . regroup . map (splitOn (== '/')) . sort

splitOn     :: (Char -> Bool) -> String -> [String]
splitOn p s =  case dropWhile p s of
                    "" -> []
                    s' -> w : splitOn p s''
                          where (w, s'') = break p s'

regroup :: Eq a => [[a]] -> [[[a]]]
regroup = groupBy ((==) `on` listToMaybe)

toTrieRoot :: [[[String]]] -> Trie String
toTrieRoot = RootTrie . map toTrieRootOne

toTrieRootOne :: [[String]] -> Trie String
toTrieRootOne l = NodeTrie name (map toTrieDeepOne (regroup ts))
  where name = head (head l)
        ts = map tail l

toTrieDeepOne :: [[String]] -> Trie String
toTrieDeepOne l = maybe EmptyTrie createNode getName
  where getName = join $ fmap listToMaybe (listToMaybe l)
        createNode name = NodeTrie name (map toTrieDeepOne (regroup (map tail l)))

evaledDocument :: [XmlElement]
evaledDocument = evalXpathsTrie strongXpaths document

evalXpathsTrie :: Trie String -> XmlElement -> [XmlElement]
evalXpathsTrie e d = case e of
                       RootTrie xs    -> concatMap (flip evalXpathsTrie d) xs
                       NodeTrie n xs  -> join $ join $ map (flip map (filterNode n d)) (map evalXpathsTrie xs)
                       EmptyTrie      -> [d]

filterNode :: String -> XmlElement -> [XmlElement]
filterNode p = filter ((p ==) . getTagName) . getChildren