module Text.XML.Selector (
query,
query1,
searchTree,
showJQ,
byId,
byClass,
selectorMatch,
next,
maybeText,
headm,
queryMatchNode
)
where
import Data.List
import qualified Data.Text as T
import Text.XML.Cursor
import Text.XML as X
import qualified Data.Map as M
import Data.Maybe
import Text.XML.Selector.Parser
import Text.XML.Selector.Types
import Debug.Trace
showJQ :: [JQSelector] -> String
showJQ ss = foldl f "" ss
where
f str sel = str ++ g (relPrev sel) ++
maybe "" id (jqTagName sel) ++
maybe "" (("#"++)) (jqTagId sel) ++
concat (map (("."++)) (jqTagClass sel)) ++
if null (jqTagAttr sel) then "" else (concatMap h (jqTagAttr sel))
g Descendant = " "
g Child = " > "
g Next = " + "
g Sibling = " ~ "
h (TagAttr k Nothing _) = "["++k++"]"
h (TagAttr k (Just v) r) = "["++k ++ relToStr r ++ "\"" ++ v ++ "\"]"
byId :: String -> Axis
byId s = checkElement (elemHasId (Just s))
byIdT s = [e| checkElement (elemHasId (Just s)) |]
byClass :: String -> Axis
byClass s = checkElement (elemHasClass [s])
next :: Cursor -> Maybe Cursor
next c = headm (c $| followingSibling)
headm :: [a] -> Maybe a
headm [] = Nothing
headm (x:_) = Just x
take1' :: [a] -> [a]
take1' xs = if null xs then [] else take 1 xs
maybeText :: T.Text -> Maybe T.Text
maybeText "" = Nothing
maybeText t = Just t
query :: String -> Axis
query keystr = case parseJQ keystr of
[] -> error "query: Invalid selector"
sels -> searchTree sels
query1 :: String -> Cursor -> Maybe Cursor
query1 s n | null res = Nothing
| otherwise = Just (head res)
where res = query s n
searchTree :: [JQSelector] -> Axis
searchTree xs = search (reverse xs)
where
search [] c = [c]
search (x@(JQSelector rel _ _ _ _):xs) c = c $// checkElement (selectorMatch x) >=> check (traceAncestors rel xs)
traceAncestors :: RelPrev -> [JQSelector] -> Axis
traceAncestors _ [] c = [c]
traceAncestors Child (x:xs) c
| isJust p = if matchCursor x (fromJust p) then traceAncestors (relPrev x) xs (fromJust p) else []
| otherwise = []
where
p :: Maybe Cursor
p = headm (parent c)
traceAncestors Descendant (x:xs) c
= case filter (matchCursor x) (ancestor c) of
[] -> []
as -> concatMap (traceAncestors (relPrev x) xs) as
traceAncestors Next (x:xs) c
| isJust p = if matchCursor x (fromJust p) then traceAncestors (relPrev x) xs (fromJust p) else []
| otherwise = []
where
p :: Maybe Cursor
p = headm (precedingSibling c)
traceAncestors Sibling (x:xs) c
= case filter (matchCursor x) (precedingSibling c) of
[] -> []
as -> concatMap (traceAncestors (relPrev x) xs) as
selectorMatch :: JQSelector -> Element -> Bool
selectorMatch (JQSelector _ name id klass attr) e
= elemIsTag name e && elemHasId id e && elemHasClass klass e && all (flip elemHasAttr e) attr
matchNode :: JQSelector -> Node -> Bool
matchNode sel (NodeElement elem) = selectorMatch sel elem
matchNode _ _ = False
matchCursor :: JQSelector -> Cursor -> Bool
matchCursor sel cursor = matchNode sel (node cursor)
queryMatchNode :: String -> Node -> Bool
queryMatchNode s (NodeElement e)
= case qq of
Just q -> selectorMatch q e
Nothing -> False
where qq = headm $ parseJQ s
queryMatchNode _ _ = False
elemIsTag :: Maybe String -> Element -> Bool
elemIsTag Nothing _ = True
elemIsTag (Just tag) (Element n _ _) = nameLocalName n == T.pack tag
elemHasId :: Maybe String -> Element -> Bool
elemHasId Nothing _ = True
elemHasId (Just id) (Element _ as _) = M.lookup "id" as == Just (T.pack id)
elemHasClass :: [String] -> Element -> Bool
elemHasClass [] _ = True
elemHasClass ks (Element _ as _) = all (`elem` kl) $ map T.pack ks
where
kl = maybe [] T.words (M.lookup "class" as)
elemHasAttr :: TagAttr -> Element -> Bool
elemHasAttr attr (Element _ as _) = relFunc (attrRel attr) (g as) (Just (fromMaybe "" (attrVal attr)))
where
relFunc :: AttrRel -> Maybe String -> Maybe String -> Bool
relFunc Equal (Just a) (Just b) = a == b
relFunc Exists a _ = isJust a
relFunc Contains (Just a) (Just b) = b `isInfixOf` a
relFunc Begin (Just a) (Just b) = b `isPrefixOf` a
relFunc End (Just a) (Just b) = b `isSuffixOf` a
relFunc NotEqual (Just a) (Just b) = a /= b
relFunc ContainsWord (Just a) (Just b) = all (`isInfixOf` a) (words b)
relFunc _ _ _ = False
toName s = Name (T.pack s) Nothing Nothing
g :: M.Map Name T.Text -> Maybe String
g as = fmap T.unpack (M.lookup (toName $ attrName attr) as)