From 12b8cb56a728491e8e2af11fbe5e98b800336da3 Mon Sep 17 00:00:00 2001 From: Rowan Torbitzky-Lane Date: Tue, 4 Feb 2025 03:36:33 -0600 Subject: [PATCH] formatting and generic tests --- src/Instructions/GenericInstructions.hs | 5 +- src/Push.hs | 3 +- src/PushTests.hs | 6 +- src/PushTests/GenericTests.hs | 88 +++++++++++++++++++++---- src/PushTests/IntTests.hs | 77 +++++++++++++++------- src/State.hs | 10 +-- test/Main.hs | 13 ++-- 7 files changed, 145 insertions(+), 57 deletions(-) diff --git a/src/Instructions/GenericInstructions.hs b/src/Instructions/GenericInstructions.hs index aac7bbc..5189d5b 100644 --- a/src/Instructions/GenericInstructions.hs +++ b/src/Instructions/GenericInstructions.hs @@ -100,12 +100,13 @@ instructionIsEmpty state@(State {_bool = bs}) accessor = state{_bool = null (vie -- I might be able to move some of the int stack error checking -- to the integer call. For now this may be a tad inefficient. -instructionDupN :: forall a. State -> Lens' State [a] -> State +instructionDupN :: forall a. Show a => State -> Lens' State [a] -> State instructionDupN state accessor = case uncons (view int state) of Just (i1,is) -> case uncons (view accessor state{_int = is}) of - Just (a1,as) -> instructionDupNHelper i1 a1 accessor (state{_int = is} & accessor .~ as) + Just (a1,as) -> + instructionDupNHelper i1 a1 accessor (state{_int = is} & accessor .~ as) _ -> state _ -> state where diff --git a/src/Push.hs b/src/Push.hs index 3e0e1f1..44c6bc8 100644 --- a/src/Push.hs +++ b/src/Push.hs @@ -2,7 +2,6 @@ module Push where import Control.Lens import Data.Map qualified as Map - import State -- import Debug.Trace (trace, traceStack) @@ -67,7 +66,7 @@ interpretExec state@(State {_exec = e : es}) = interpretExec state = state -- interpretOneStep :: State -> State --- interpretOneStep state@(State {_exec = e : es}) = +-- interpretOneStep state@(State {_exec = e : es}) = -- case e of -- (GeneInt val) -> state & exec .~ es & int .~ val : view int state -- (GeneFloat val) -> state & exec .~ es & float .~ val : view float state diff --git a/src/PushTests.hs b/src/PushTests.hs index c0db3b0..eca2dc5 100644 --- a/src/PushTests.hs +++ b/src/PushTests.hs @@ -1,6 +1,6 @@ -module PushTests - ( module PushTests.GenericTests - , module PushTests.IntTests +module PushTests + ( module PushTests.GenericTests, + module PushTests.IntTests, ) where diff --git a/src/PushTests/GenericTests.hs b/src/PushTests/GenericTests.hs index a983b94..2ec8820 100644 --- a/src/PushTests/GenericTests.hs +++ b/src/PushTests/GenericTests.hs @@ -3,24 +3,84 @@ module PushTests.GenericTests where import State import Control.Lens import Debug.Trace +import Test.QuickCheck -arithmeticTest :: (Num a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a -> a) -> State -> Bool -arithmeticTest accessor instruction func state = +-- The naming scheme: +-- the letters at the beginning represent what kind of transformation (the word I'm using for a basic function) to the states is happening +-- for example: the function aaa1Test relays this arg takes a transformation of two as and turns them into one a +-- the numbers represent how many different stacks are used in the function. +-- for example: the aaa1Test relays that it takes one stack as input. These stacks are passed in as Lens + +-- We may be able to get rid of Lens entirely and use haskell's integrated accessors of type State -> [a] +-- You can see what I'm talking about if you go into ghci and type: `:info _int` for example + +aaa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a -> a) -> State -> Property +aaa1Test accessor instruction transformation state = case (uncons (view accessor state), uncons (view accessor $ instruction state)) of - (Just (origx1, origx2 : _), Just (modx1, _)) -> func origx2 origx1 == modx1 && length (view accessor state) == length (view accessor $ instruction state) + 1 - _ -> state == instruction state + (Just (origx1, origx2 : _), Just (modx1, _)) -> transformation origx2 origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) + 1 + _ -> state === instruction state -unaryTest :: (Num a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Bool -unaryTest accessor instruction func state = +aa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Property +aa1Test accessor instruction transformation state = case (uncons (view accessor state), uncons (view accessor $ instruction state)) of - (Just (origx1, _), Just (modx1, _)) -> func origx1 == modx1 && length (view accessor state) == length (view accessor $ instruction state) - _ -> state == instruction state + (Just (origx1, _), Just (modx1, _)) -> transformation origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) + _ -> state === instruction state -typeFromType :: Eq b => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Bool -typeFromType accessorFrom accessorTo instruction transformation state = +ab1Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Property +ab1Test accessorFrom accessorTo instruction transformation state = case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of (Just (t1, _), Just (f1, _)) -> - t1 == transformation f1 && - length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 && - length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 1 - _ -> state == instruction state + t1 === transformation f1 .&&. + length (view accessorTo $ instruction state) === length (view accessorTo state) + 1 .&&. + length (view accessorFrom $ instruction state) === length (view accessorFrom state) - 1 + _ -> state === instruction state + +aab2Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> a -> b) -> State -> Property +aab2Test accessorFrom accessorTo instruction transformation state = + case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of + (Just (t1, _), Just (f1, f2 : _)) -> + t1 === transformation f1 f2 .&&. + length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 .&&. + length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 2 + _ -> state === instruction state + +popTest :: (Show a) => Lens' State [a] -> (State -> State) -> State -> Property +popTest accessor instruction state = + if null $ view accessor state + then state === instruction state + else length (view accessor $ instruction state) === length (view accessor state) - 1 + +dupTest :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property +dupTest accessor instruction state = + case uncons (view accessor state) of + Just (origx1, _) -> + case uncons (view accessor $ instruction state) of + Just (modx1, modx2 : _) -> + origx1 === modx1 .&&. origx1 === modx2 .&&. length (view accessor $ instruction state) === length (view accessor state) + 1 + _ -> state === instruction state + _ -> state === instruction state + +-- How to test the int stack in particular? +dupTestN :: (Eq a, Show a) => Lens' State [a] -> (State -> State) -> State -> Property +dupTestN accessor instruction state = + case uncons (view int state) of + Just (i1, is) -> + let amt = max i1 0 in + case uncons (view accessor state{_int = is}) of + Just (origx1, _) -> + conjoin (map (origx1 ===) (take amt (view accessor $ instruction state))) .&&. + length (view accessor $ instruction state) === (length (view accessor state{_int = is}) + amt - 1) + _ -> state === instruction state + _ -> state === instruction state + +swapTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +swapTest accessor instruction state = + case (uncons (view accessor state), uncons (view accessor $ instruction state)) of + (Just (origx1, origx2 : _), Just (modx1, modx2 : _)) -> origx1 === modx2 .&&. origx2 === modx1 + _ -> state === instruction state + +rotTest :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> State -> Property +rotTest accessor instruction state = + case (uncons (view accessor state), uncons (view accessor $ instruction state)) of + (Just (origx1, origx2 : origx3 : _), Just (modx1, modx2 : modx3 : _)) -> (origx1, origx2, origx3) === (modx2, modx3, modx1) + _ -> state === instruction state diff --git a/src/PushTests/IntTests.hs b/src/PushTests/IntTests.hs index 0293a5d..f0249dd 100644 --- a/src/PushTests/IntTests.hs +++ b/src/PushTests/IntTests.hs @@ -3,40 +3,67 @@ module PushTests.IntTests where import State import Instructions.IntInstructions import PushTests.GenericTests -import Data.List import Control.Lens hiding (uncons) +import Test.QuickCheck -prop_IntAdd :: State -> Bool -prop_IntAdd = arithmeticTest int instructionIntAdd (+) +prop_IntAdd :: State -> Property +prop_IntAdd = aaa1Test int instructionIntAdd (+) -prop_IntSub :: State -> Bool -prop_IntSub = arithmeticTest int instructionIntSub (-) +prop_IntSub :: State -> Property +prop_IntSub = aaa1Test int instructionIntSub (-) -prop_IntMul :: State -> Bool -prop_IntMul = arithmeticTest int instructionIntMul (*) +prop_IntMul :: State -> Property +prop_IntMul = aaa1Test int instructionIntMul (*) -prop_IntDiv :: State -> Bool -prop_IntDiv state@(State {_int = 0 : _}) = state == instructionIntDiv state -prop_IntDiv state = arithmeticTest int instructionIntDiv div state +prop_IntDiv :: State -> Property +prop_IntDiv state@(State {_int = 0 : _}) = state === instructionIntDiv state +prop_IntDiv state = aaa1Test int instructionIntDiv div state -prop_IntMod :: State -> Bool -prop_IntMod state@(State {_int = 0 : _}) = state == instructionIntMod state -prop_IntMod state = arithmeticTest int instructionIntMod mod state +prop_IntMod :: State -> Property +prop_IntMod state@(State {_int = 0 : _}) = state === instructionIntMod state +prop_IntMod state = aaa1Test int instructionIntMod mod state -prop_IntFromFloat :: State -> Bool -prop_IntFromFloat = typeFromType float int instructionIntFromFloat floor +prop_IntFromFloat :: State -> Property +prop_IntFromFloat = ab1Test float int instructionIntFromFloat floor -prop_IntFromBool :: State -> Bool -prop_IntFromBool = typeFromType bool int instructionIntFromBool (\x -> if x then 1 else 0) +prop_IntFromProperty :: State -> Property +prop_IntFromProperty = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0) -prop_IntMin :: State -> Bool -prop_IntMin = arithmeticTest int instructionIntMin min +prop_IntMin :: State -> Property +prop_IntMin = aaa1Test int instructionIntMin min -prop_IntMax :: State -> Bool -prop_IntMax = arithmeticTest int instructionIntMax max +prop_IntMax :: State -> Property +prop_IntMax = aaa1Test int instructionIntMax max -prop_IntInc :: State -> Bool -prop_IntInc = unaryTest int instructionIntInc (+1) +prop_IntInc :: State -> Property +prop_IntInc = aa1Test int instructionIntInc (+1) -prop_IntDec :: State -> Bool -prop_IntDec = unaryTest int instructionIntDec (\x -> x - 1) +prop_IntDec :: State -> Property +prop_IntDec = aa1Test int instructionIntDec (\x -> x - 1) + +prop_IntLT :: State -> Property +prop_IntLT = aab2Test int bool instructionIntLT (<) + +prop_IntGT :: State -> Property +prop_IntGT = aab2Test int bool instructionIntGT (>) + +prop_IntLTE :: State -> Property +prop_IntLTE = aab2Test int bool instructionIntLTE (<=) + +prop_IntGTE :: State -> Property +prop_IntGTE = aab2Test int bool instructionIntGTE (>=) + +prop_IntDup :: State -> Property +prop_IntDup = dupTest int instructionIntDup + +prop_IntPop :: State -> Property +prop_IntPop = popTest int instructionIntPop + +prop_IntDupN :: State -> Property +prop_IntDupN = dupTestN int instructionIntDupN + +prop_IntSwap :: State -> Property +prop_IntSwap = swapTest int instructionIntSwap + +prop_IntRot :: State -> Property +prop_IntRot = rotTest int instructionIntRot diff --git a/src/State.hs b/src/State.hs index df6737a..cfd4071 100644 --- a/src/State.hs +++ b/src/State.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE TemplateHaskell, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} module State where import Control.Lens hiding (elements) import Data.Map qualified as Map -import Test.QuickCheck import GHC.Generics +import Test.QuickCheck -- The exec stack must store heterogenous types, -- and we must be able to detect that type at runtime. @@ -26,7 +27,7 @@ data Gene | PlaceInput String | Close | Block [Gene] - deriving Generic + deriving (Generic) instance Eq Gene where GeneInt x == GeneInt y = x == y @@ -61,7 +62,6 @@ instance Show Gene where show Close = "Close" show (Block xs) = "Block: " <> show xs - instance CoArbitrary Gene instance Arbitrary Gene where @@ -83,7 +83,6 @@ instance Arbitrary Gene where return Close ] - data State = State { _exec :: [Gene], _code :: [Gene], @@ -119,6 +118,7 @@ instance Arbitrary State where arbParameter <- arbitrary -- arbInput <- arbitrary State arbExec arbCode arbInt arbFloat arbBool arbString arbChar arbVectorInt arbVectorFloat arbVectorBool arbVectorString arbVectorChar arbParameter <$> arbitrary + -- Thanks hlint lol instance CoArbitrary State diff --git a/test/Main.hs b/test/Main.hs index cadba10..e923449 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,20 +1,21 @@ import Instructions import Push +import PushTests import State import Test.QuickCheck -import PushTests + -- import Data.List --- import Control.Lens +-- import Control.Lens -- import Debug.Trace pushTestArgs :: Args -pushTestArgs = stdArgs{maxSize = 10} - +pushTestArgs = stdArgs {maxSize = 10} + -- These two used for ghci testing -- For example (in ghci): qcw prop_myTest -qcw :: Testable a => a -> IO () +qcw :: (Testable a) => a -> IO () qcw = quickCheckWith pushTestArgs -vcw :: Testable a => a -> IO () +vcw :: (Testable a) => a -> IO () vcw = verboseCheckWith pushTestArgs