You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
86 lines
2.4 KiB
86 lines
2.4 KiB
12 years ago
|
module Tests.Arbitrary.Xml where
|
||
|
|
|
||
|
|
import Control.Applicative ((<$>), (<*>))
|
||
|
|
import Test.QuickCheck
|
||
|
|
import Test.QuickCheck.Instances()
|
||
|
|
-- import Data.DeriveTH
|
||
|
|
import qualified Data.Text as Text
|
||
|
|
import Data.XML.Types
|
||
|
|
import Tests.Arbitrary.Common
|
||
|
|
import Text.CharRanges
|
||
|
|
|
||
|
|
|
||
|
|
selectFromRange :: Range -> Gen Char
|
||
|
|
selectFromRange (Single a) = return a
|
||
|
|
selectFromRange (Range a b) = choose (a, b)
|
||
|
|
|
||
|
|
nameStartChar :: [Range]
|
||
|
|
nameStartChar =
|
||
|
|
[ -- Single ':'
|
||
|
|
Single '_'
|
||
|
|
, Range 'A' 'Z'
|
||
|
|
, Range 'a' 'z'
|
||
|
|
, Range '\xC0' '\xD6'
|
||
|
|
, Range '\xD8' '\xF6'
|
||
|
|
, Range '\xF8' '\x2FF'
|
||
|
|
, Range '\x370' '\x37D'
|
||
|
|
, Range '\x37F' '\x1FFF'
|
||
|
|
, Range '\x200C' '\x200D'
|
||
|
|
, Range '\x2070' '\x218F'
|
||
|
|
, Range '\x2C00' '\x2FEF'
|
||
|
|
, Range '\x3001' '\xD7FF'
|
||
|
|
, Range '\xF900' '\xFDCF'
|
||
|
|
, Range '\xFDF0' '\xFFFD'
|
||
|
|
, Range '\x10000' '\xEFFFF'
|
||
|
|
]
|
||
|
|
|
||
|
|
nameChar :: [Range]
|
||
|
|
nameChar =
|
||
|
|
Single '-'
|
||
|
|
: Single '.'
|
||
|
|
: Single '\xB7'
|
||
|
|
: Range '0' '9'
|
||
|
|
: Range '\x0300' '\x036F'
|
||
|
|
: Range '\x203F' '\x2040'
|
||
|
|
: nameStartChar
|
||
|
|
|
||
|
|
|
||
|
|
genNCName :: Gen Text.Text
|
||
|
|
genNCName = do
|
||
|
|
sc <- elements nameStartChar >>= selectFromRange
|
||
|
|
ncs <- listOf $ elements nameChar >>= selectFromRange
|
||
|
|
return . Text.pack $ sc:ncs
|
||
|
|
|
||
|
|
-- | Cap the size of child elements.
|
||
|
|
slow :: Gen a -> Gen a
|
||
|
|
slow g = sized $ \n -> resize (min 5 (n `div` 4)) g
|
||
|
|
|
||
|
|
instance Arbitrary Name where
|
||
|
|
arbitrary = Name <$> genNCName <*> genMaybe genNCName <*> genMaybe genNCName
|
||
|
|
where
|
||
|
|
genMaybe g = oneof [return Nothing, Just <$> g]
|
||
|
|
shrink (Name a b c) = [ Name a' b c | a' <- shrinkText1 a]
|
||
|
|
++[ Name a b' c | b' <- shrinkTextMaybe b]
|
||
|
|
++[ Name a b c' | c' <- shrinkTextMaybe c]
|
||
|
|
|
||
|
|
instance Arbitrary Content where
|
||
|
|
arbitrary = ContentText <$> arbitrary
|
||
|
|
shrink (ContentText txt) = ContentText <$> shrinkText1 txt
|
||
|
|
shrink _ = []
|
||
|
|
|
||
|
|
|
||
|
|
instance Arbitrary Node where
|
||
|
|
arbitrary = oneof [ NodeElement <$> arbitrary
|
||
|
|
, NodeContent <$> arbitrary
|
||
|
|
]
|
||
|
|
shrink (NodeElement e) = NodeElement <$> shrink e
|
||
|
|
shrink (NodeContent c) = NodeContent <$> shrink c
|
||
|
|
shrink _ = []
|
||
|
|
|
||
|
|
instance Arbitrary Element where
|
||
|
|
arbitrary = Element <$> arbitrary <*> slow arbitrary <*> slow arbitrary
|
||
|
|
shrink (Element a b c) =
|
||
|
|
[ Element a' b c | a' <- shrink a]
|
||
|
|
++[ Element a b' c | b' <- shrink b]
|
||
|
|
++[ Element a b c' | c' <- shrink c]
|