QuickCheck generator for Canonicalized and Normal URI generation

ArbitraryInstances.hs

module Test.Util.ArbitraryInstances where

import Data.List           (intercalate)
import Control.Applicative ((<$>), (<*>), pure)
import Network.URI         (URI(..), URIAuth(..), uriToString)
import Test.QuickCheck

newtype URIPair
  = URIPair { fromPair :: (String, String) }
  deriving (Show)

genWord :: Gen String
genWord = listOf1 (choose ('a', 'z'))

genCanonicalURI :: Gen URI
genCanonicalURI =
    URI <$> elements ["http:", "https:"]
        <*> (Just <$> genURIAuthority)
        <*> (('/':) <$> genPaths)
        <*> pure ""
        <*> pure ""
  where
    genURIAuthority =
      URIAuth <$> pure ""
              <*> genRegName
              <*> pure ""
    genRegName = do
      domainName <- elements ["noomii", "google", "yahoo"]
      return $ concat ["www.", domainName, ".com"]
    genPaths = resize 10 (intercalate "/" <$> listOf genWord)

genNormalURI :: URI -> Gen URI
genNormalURI uri = do
    qs  <- genQueryString
    fragment <-  genFragment
    return $ uri { uriQuery = qs, uriFragment = fragment }
  where
    genParam = do
      name  <- genWord
      value <- genWord
      return $ name ++ "=" ++ value
    genQueryString = resize 10 $
      ('?':) <$> (intercalate "&" <$> listOf genParam)
    genFragment = ('#':) <$> genWord

instance Arbitrary URIPair where
    arbitrary = do
      canonical <- genCanonicalURI
      normal    <- genNormalURI canonical
      return (URIPair (uriToString id canonical "", uriToString id normal ""))

QuickCheckTest.hs

module Network.HTTP.Internal.Crawler (tests) where

import Test.Framework                       (Test, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)

import Test.Util.ArbitraryInstances 
import Network.HTTP.Internal.Crawler (canonicalizeLink)

tests :: [Test]
tests =
    [ testCanonicalizeLink
    ]

testCanonicalizeLink :: Test
testCanonicalizeLink = testProperty "check canonicalize work" prop_Canonicalize
  where
    prop_Canonicalize :: URIPair -> Bool
    prop_Canonicalize (URIPair (canon, normal)) = 
        canonicalizeLink normal == canon

TestSuite.hs

module Main where

import Test.Framework (defaultMain, testGroup)

import qualified Network.HTTP.Internal.Crawler.Tests

main :: IO ()
main = defaultMain tests
  where
    tests =
      [
        testGroup "Network.HTTP.Internal.Crawler.Tests"
                   Network.HTTP.Internal.Crawler.Tests.tests
      ]

Hello Roman! Your code was very useful in our project. Thanks!