gistfile1.txt

import Data.IORef
import Test.QuickCheck
import Test.QuickCheck.Monadic

data Queue a = Queue (IORef [a])

empty :: IO (Queue a)
empty = do
    ref <- newIORef []
    return (Queue ref)

add :: Queue a -> a -> IO ()
add (Queue ref) x = do
    modifyIORef ref (\l -> l ++ [x])

remove :: Queue a -> IO ()
remove (Queue ref) = do
    modifyIORef ref (tail)

front :: Queue a -> IO (Maybe a)
front (Queue ref) = do
    l <- readIORef ref
    case l of
        [] -> return Nothing
        h:_ -> return (Just h)

data Action
    = Add Int
    | Remove
    | Front
    | Return (Maybe Int)
    deriving (Eq, Show)

perform :: Queue Int -> [Action] -> IO [Maybe Int]
perform _ [] = return []
perform q (a:as) =
    case a of
        Add n -> do
            add q n
            perform q as
        Remove -> do
            remove q
            perform q as
        Front -> do
            x <- front q
            r <- perform q as
            return (x:r)
        Return x -> do
            r <- perform q as
            return (x:r)

actions :: Int -> Gen [Action]
actions n = oneof (
    [ do
        return []
    , do 
        a <- arbitrary
        r <- actions (n + 1)
        return $ (Add a) : r
    , do
        r <- actions n
        return (Front : r)
    ]
    ++ if n == 0 then []
        else [ do
            r <- actions (n - 1)
            return $ (Remove : r)
        ]
    )

delta :: [Action] -> Int
delta [] = 0
delta ((Add _):xs) = delta xs + 1
delta (Remove:xs) = delta xs - 1
delta (_:xs) = delta xs

(~=) :: [Action] -> [Action] -> Property
c ~= c' =
    forAll (actions 0) $ \pref ->
        forAll (actions (delta (pref ++ c))) $ \suff -> monadicIO $ do
            let observe x = do
                    q <- empty
                    perform q (pref ++ x ++ suff)
            r1 <- run $ observe c
            r2 <- run $ observe c'
            assert $ r1 == r2

(~=^) :: [Action] -> [Action] -> Property
c ~=^ c' =
    forAll (actions (delta c)) $ \suff -> monadicIO $ do
        let observe x = do
                q <- empty
                perform q (x ++ suff)
        r1 <- run $ observe c
        r2 <- run $ observe c'
        assert $ r1 == r2

prop_FrontAdd :: Int -> Int -> Property
prop_FrontAdd m n =
    [Add m, Add n, Front] ~= [Add m, Front, Add n]

prop_AddRemove :: Int -> Int -> Property
prop_AddRemove m n =
    [Add m, Add n, Remove] ~= [Add m, Remove, Add n]

prop_FrontEmpty :: Property
prop_FrontEmpty =
    [Front] ~=^ [Return Nothing]

prop_FrontAddEmpty :: Int -> Property
prop_FrontAddEmpty m =
    [Add m, Front] ~=^ [Add m, Return (Just m)]

prop_AddRemoveEmpty :: Int -> Property
prop_AddRemoveEmpty m =
    [Add m, Remove] ~=^ []

main :: IO ()
main = do
    quickCheck prop_FrontAdd
    quickCheck prop_AddRemove
    quickCheck prop_FrontEmpty
    quickCheck prop_FrontAddEmpty
    quickCheck prop_AddRemoveEmpty