git.iko.soy/typeable/hexml
on master help sign in
typeable/hexml/src/Main.hs
84 lines 3.5 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
3module Main(main) where
5import Text.XML.Hexml as X
6import qualified Data.ByteString.Char8 as BS
7import Control.Monad
8import Data.Monoid
9import Data.Char
10import Prelude
13examples :: [(Bool, BS.ByteString)]
14examples =
15 [(True, "<test id='bob'>here<extra/>there</test>")
16 ,(True, "<test /><close />")
17 ,(True, "<test /><!-- comment > --><close />")
18 ,(True, "<test id=\"bob value\" another-attr=\"test with <\">here </test> more text at the end<close />")
19 ,(False, "<test></more>")
20 ,(False, "<test")
21 ,(True, "<?xml version=\"1.1\"?>\n<greeting>Hello, world!</greeting>")
22 ,(True, "<foo bar.baz=\"qux\"></foo>")
23 ]
25main :: IO ()
26main = do
27 forM_ examples $ \(parses, src) ->
28 case parse src of
29 Left err -> when parses $ fail $ "Unexpected parse failure, " ++ show err
30 Right doc -> do
31 unless parses $ fail "Unexpected parse success"
32 checkFind doc
33 let r = render doc
34 r === rerender doc
35 let Right d = parse r
36 r === render d
38 let Right doc = parse "<test id=\"1\" extra=\"2\" />\n<test id=\"2\" /><b><test id=\"3\" /></b><test id=\"4\" /><test />"
39 map name (children doc) === ["test","test","b","test","test"]
40 location (children doc !! 2) === (2,16)
41 length (childrenBy doc "test") === 4
42 length (childrenBy doc "b") === 1
43 length (childrenBy doc "extra") === 0
44 attributes (head $ children doc) === [Attribute "id" "1", Attribute "extra" "2"]
45 map (`attributeBy` "id") (childrenBy doc "test") === map (fmap (Attribute "id")) [Just "1", Just "2", Just "4", Nothing]
47 Right _ <- pure $ parse $ "<test " <> BS.unwords [BS.pack $ "x" ++ show i ++ "='value'" | i <- [1..10000]] <> " />"
48 Right _ <- pure $ parse $ BS.unlines $ replicate 10000 "<test x='value' />"
50 let attrs = ["usd:jpy","test","extra","more","stuff","jpy:usd","xxx","xxxx"]
51 Right doc <- pure $ parse $ "<test " <> BS.unwords [x <> "='" <> x <> "'" | x <- attrs] <> ">middle</test>"
52 [c] <- pure $ childrenBy doc "test"
53 forM_ attrs $ \a -> attributeBy c a === Just (Attribute a a)
54 forM_ ["missing","gone","nothing"] $ \a -> attributeBy c a === Nothing
55 putStrLn "\nSuccess"
58checkFind :: Node -> IO ()
59checkFind n = do
60 forM_ (attributes n) $ \a -> attributeBy n (attributeName a) === Just a
61 attributeBy n "xxx" === Nothing
62 let cs = children n
63 forM_ ("xxx":map name cs) $ \c ->
64 map outer (filter ((==) c . name) cs) === map outer (childrenBy n c)
65 mapM_ checkFind $ children n
68a === b = if a == b then putChar '.' else fail $ "mismatch, " ++ show a ++ " /= " ++ show b
70rerender :: Node -> BS.ByteString
71rerender = inside
72 where
73 inside x = BS.concat $ map (either validStr node) $ contents x
74 node x = "<" <> BS.unwords (validName (name x) : map attr (attributes x)) <> ">" <>
75 inside x <>
76 "</" <> name x <> ">"
77 attr (Attribute a b) = validName a <> "=\"" <> validAttr b <> "\""
79 validName x | BS.all (\x -> isAlphaNum x || x `elem` ("-.:_" :: String)) x = x
80 | otherwise = error "Invalid name"
81 validAttr x | BS.notElem '\"' x = x
82 | otherwise = error "Invalid attribute"
83 validStr x | BS.notElem '<' x || BS.isInfixOf "<!--" x = x
84 | otherwise = error $ show ("Invalid string", x)