{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -- for quickchecking (Maybe Int) module Tests where import Test.QuickCheck import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Monad.Error import Control.Monad.List import Control.Monad.Identity import Control.Monad.ReaderX import Control.Monad.StateX import Control.Monad.WriterX import Control.Monad.ErrorX import Control.Monad.ListX import Control.Monad.IdentityX import qualified Data.Map as D import Char import System import Examples -- ---------------------------------------------------------------- -- ---------------------------------------------------------------- -- ---------------------------------------------------------------- -- ---------------------------------------------------------------- data Xs = Q0 | Q1 | Q2 | Q3 | Q4 | Q5 | Q6 | Q7 | Q8 deriving (Show, Eq) data StateAction = GetFrom Xs | PutTo Xs Int deriving (Show, Eq) example = [GetFrom Q1, GetFrom Q2, PutTo Q1 14, PutTo Q2 15, GetFrom Q3 ] instance Arbitrary X1 where arbitrary = return X1; coarbitrary X1 gen = variant 1 gen instance Arbitrary X2 where arbitrary = return X2; coarbitrary X2 gen = variant 1 gen instance Arbitrary X3 where arbitrary = return X3; coarbitrary X3 gen = variant 1 gen instance Arbitrary X4 where arbitrary = return X4; coarbitrary X4 gen = variant 1 gen instance Arbitrary X5 where arbitrary = return X5; coarbitrary X5 gen = variant 1 gen instance Arbitrary X6 where arbitrary = return X6; coarbitrary X6 gen = variant 1 gen instance Arbitrary X7 where arbitrary = return X7; coarbitrary X7 gen = variant 1 gen instance Arbitrary X8 where arbitrary = return X8; coarbitrary X8 gen = variant 1 gen numOfXs xs = case xs of Q0->0; Q1->1; Q2->2; Q3->3; Q4->4; Q5->5; Q6->6; Q7->7; Q8->8; instance Arbitrary Xs where arbitrary = oneof (map return [Q0,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8]) coarbitrary xs gen = variant (numOfXs xs) gen xsToInt Q0 = 0 xsToInt Q1 = 1 xsToInt Q2 = 2 xsToInt Q3 = 3 xsToInt Q4 = 4 xsToInt Q5 = 5 xsToInt Q6 = 6 xsToInt Q7 = 7 xsToInt Q8 = 8 ------------------------------------------------------------------------- ------------------------------------------------------------------------- ---- ---- ---- deepCheck p = check (defaultConfig {configMaxTest = 300}) p gen_Xs :: Int -> Gen Xs gen_Xs n = frequency $ zip freqs (map return [Q0,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8]) where freqs = map (uncurry matchAgainst) $ zip [0..8] (replicate 9 n) matchAgainst a b = if a==b then 0 else 1 genStateActions :: Int -> Gen [StateAction] genStateActions n = oneof [morph GetFrom, choose (0,20) >>= \v -> morph (flip PutTo v), return [] ] where morph constr = do a <- gen_Xs n b <- genStateActions n return ((constr a):b) knowme :: (MonadStateX X1 Int m, MonadStateX X2 Int m, MonadStateX X3 Int m, MonadStateX X4 Int m, MonadStateX X5 Int m, MonadStateX X6 Int m, MonadStateX X7 Int m, MonadStateX X8 Int m, MonadState Int m ) => m a -> m a knowme q = q runme q = id . fst . fst . fst . fst . fst . fst . fst . fst . fst . flip23 runStateX X1 1 . flip23 runStateTX X2 2 . flip23 runStateTX X3 3 . flip23 runStateTX X4 4 . flip23 runStateTX X5 5 . flip23 runStateTX X6 6 . flip23 runStateTX X7 7 . flip23 runStateTX X8 8 . flip runStateT 9 $ knowme q getfrom (GetFrom Q0) = (knowme $ get ) getfrom (GetFrom Q1) = (knowme $ getx X1) getfrom (GetFrom Q2) = (knowme $ getx X2) getfrom (GetFrom Q3) = (knowme $ getx X3) getfrom (GetFrom Q4) = (knowme $ getx X4) getfrom (GetFrom Q5) = (knowme $ getx X5) getfrom (GetFrom Q6) = (knowme $ getx X6) getfrom (GetFrom Q7) = (knowme $ getx X7) getfrom (GetFrom Q8) = (knowme $ getx X8) putto (PutTo Q0 v) = (knowme $ put v) putto (PutTo Q1 v) = (knowme $ putx X1 v) putto (PutTo Q2 v) = (knowme $ putx X2 v) putto (PutTo Q3 v) = (knowme $ putx X3 v) putto (PutTo Q4 v) = (knowme $ putx X4 v) putto (PutTo Q5 v) = (knowme $ putx X5 v) putto (PutTo Q6 v) = (knowme $ putx X6 v) putto (PutTo Q7 v) = (knowme $ putx X7 v) putto (PutTo Q8 v) = (knowme $ putx X8 v) {- bindStateActions transforms a list of StateActions into the actual monadic computation consisting of those. -} bindStateActions :: ( MonadStateX X1 Int m, MonadStateX X2 Int m, MonadStateX X3 Int m, MonadStateX X4 Int m, MonadStateX X5 Int m, MonadStateX X6 Int m, MonadStateX X7 Int m, MonadStateX X8 Int m, MonadState Int m ) => [StateAction] -> m Int bindStateActions [] = return 1 bindStateActions (a:as) = case a of v@(GetFrom _) -> getfrom v >> bindStateActions as v@(PutTo _ _) -> putto v >> bindStateActions as sizedactionlist skip = sized $ actionlist skip actionlist :: Int -> Int -> Gen [StateAction] actionlist skip n | n < 0 = actionlist skip (abs n) actionlist skip n | n == 0 = return [] actionlist skip n | n > 0 = oneof [ morph GetFrom, choose (0,20) >>= \v -> morph (flip PutTo v) ] where morph constr = do a <- gen_Xs skip b <- actionlist skip (n-1) return ((constr a):b) --tests that performing something in the original state monad is the --same as performing it in the indexed monad. This seems to be an --incomplete check for now. Too constructed. prop_State_vs_StateX_1 :: Int -> Int -> Bool prop_State_vs_StateX_1 init store = a == b where a = runState (put store >> get) init b = runStateX X1 (putx X1 store >> getx X1) init --Tests over the 8 indexed state monads and one original state monad. --Selects one, then puts and gets from it, and tests that doing the --same with any number of gets and puts from other state monads has no --effect on the result. prop_NonInteraction :: Int -> Property prop_NonInteraction len = forAll (arbitrary::Gen Xs) $ \xs -> forAll (actionlist (xsToInt xs) len) $ \s -> -- collect ((PutTo xs 314):s++[GetFrom xs]) $ alone xs == (sandwiched xs s) where pre xs = putto (PutTo xs 314) post xs = getfrom (GetFrom xs) alone xs = runme . knowme $ pre xs >> return () >> post xs sandwiched xs meat = runme . knowme $ pre xs >> bindStateActions meat >> post xs ---- ---- ---- ------------------------------------------------------------------------- ------------------------------------------------------------------------- -- Reader will be tested with [(Int,String)] environments and Int carriers. data ReaderAction = Local Xs (D.Map R R) ReaderAction | Ask Xs | BindInt ReaderAction (D.Map Int ReaderAction) | BindEnv ReaderAction (D.Map R ReaderAction) | BindInt2 ReaderAction ReaderAction | BindEnv2 ReaderAction ReaderAction | ReturnInt Int | ReturnEnv R -- not deriving Show or Eq. the maps stink it up. instance Show ReaderAction where show (Local x rtor ra) = "Local "++(show x)++" ("++(show ra)++")" show (Ask x) = "Ask "++(show x) show (BindInt ra inttora) = "BindInt ("++(show ra)++")" type R = [(String,Int)] --type RMap = R -> R --generates integers in the given range. This is just choose (a,b)! numGen a b = oneof $ map return [a..b] {- readexample = [ Local Q1 (\a -> ("x",3):a) (Local Q2 (\b->("x",5):b) (BindEnv Ask (\r-> ReturnInt $ lookup "x" r)) ) ] -} {- We want to check that when one reader monad has an environment, that we can do anything else and not edit its content. This implies that we can bind deeply with others' locals, for instance, as long as it doesn't change what the original. I'm only using an Env for local's parameter, instead of (Env->Env). It just screws with Eq and Show instances and I don't feel like dealing with that. Actually, I'm struggling to actually create a data Structure that successfully lets me describe the monadic computations I want to build; the types seem to get recursive and I get lost. I think that since I'm trying to test things at the type level, that this is becoming a strenuous way to error-check my code. -} -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- /'\ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --/ \-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -| EOF |- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --\ /-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- \,/ -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --