git.iko.soy/typeable/hexml
on 2d8de63 help sign in
typeable/hexml/src/Main.hs
65 lines 2.7 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
12examples :: [(Bool, BS.ByteString)]
13examples =
14 [(True, "<test id='bob'>here<extra/>there</test>")
15 ,(True, "<test /><close />")
16 ,(True, "<test /><!-- comment > --><close />")
17 ,(True, "<test id=\"bob value\" another-attr=\"test with <\">here </test> more text at the end<close />")
18 ,(False, "<test></more>")
19 ,(False, "<test")
20 ,(True, "<?xml version=\"1.1\"?>\n<greeting>Hello, world!</greeting>")
21 ]
23main :: IO ()
24main = do
25 forM_ examples $ \(parses, src) -> do
26 print src
27 case parse src of
28 Left err -> when parses $ fail $ "Unexpected parse failure, " ++ show err
29 Right doc -> do
30 unless parses $ fail "Unexpected parse success"
31 let r = render doc
32 print r
33 print $ rerender doc
34 when (r /= rerender doc) $ fail "Different rerender"
35 let Right d = parse r
36 when (r /= render d) $ fail "Different after rerendering"
38 let Right doc = parse "<test id=\"1\" extra=\"2\" /><test id=\"2\" /><b><test id=\"3\" /></b><test id=\"4\" /><test />"
39 map name (children doc) === ["test","test","b","test","test"]
40 length (childrenBy doc "test") === 4
41 length (childrenBy doc "b") === 1
42 length (childrenBy doc "extra") === 0
43 attributes (head $ children doc) === [Attribute "id" "1", Attribute "extra" "2"]
44 map (`attributeBy` "id") (childrenBy doc "test") === map (fmap (Attribute "id")) [Just "1", Just "2", Just "4", Nothing]
46 Right _ <- return $ parse $ "<test " <> BS.unwords [BS.pack $ "x" ++ show i ++ "='value'" | i <- [1..10000]] <> " />"
47 return ()
49a === b = if a == b then putStrLn "success" else fail "mismatch"
51rerender :: Node -> BS.ByteString
52rerender = inside
53 where
54 inside x = BS.concat $ map (either validStr node) $ contents x
55 node x = "<" <> BS.unwords (validName (name x) : map attr (attributes x)) <> ">" <>
56 inside x <>
57 "</" <> name x <> ">"
58 attr (Attribute a b) = validName a <> "=\"" <> validAttr b <> "\""
60 validName x | BS.all (\x -> isAlphaNum x || x `elem` ("-:_" :: String)) x = x
61 | otherwise = error "Invalid name"
62 validAttr x | BS.notElem '\"' x = x
63 | otherwise = error "Invalid attribute"
64 validStr x | BS.notElem '<' x || BS.isInfixOf "<!--" x = x
65 | otherwise = error $ show ("Invalid string", x)