pontarius-xmpp/tests/Tests/Arbitrary/Xml.hs

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]