formatting and generic tests

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

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)

src/PushTests.hs

@@ -1,6 +1,6 @@
 module PushTests
-  ( module PushTests.GenericTests
+  ( module PushTests.GenericTests,
-  , module PushTests.IntTests
+    module PushTests.IntTests,
   )
 where
 

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
+-- The naming scheme:
-arithmeticTest accessor instruction func state =
+-- 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
+    (Just (origx1, origx2 : _), Just (modx1, _)) -> transformation origx2 origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state) + 1
-    _ -> state == instruction state
+    _ -> state === instruction state
 
-unaryTest :: (Num a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Bool
+aa1Test :: (Show a, Eq a) => Lens' State [a] -> (State -> State) -> (a -> a) -> State -> Property
-unaryTest accessor instruction func state =
+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)
+    (Just (origx1, _), Just (modx1, _)) -> transformation origx1 === modx1 .&&. length (view accessor state) === length (view accessor $ instruction state)
-    _ -> state == instruction state
+    _ -> state === instruction state
 
-typeFromType :: Eq b => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Bool
+ab1Test :: (Show b, Eq b) => Lens' State [a] -> Lens' State [b] -> (State -> State) -> (a -> b) -> State -> Property
-typeFromType accessorFrom accessorTo instruction transformation state =
+ab1Test accessorFrom accessorTo instruction transformation state =
   case (uncons (view accessorTo $ instruction state), uncons (view accessorFrom state)) of
     (Just (t1, _), Just (f1, _)) -> 
-      t1 == transformation f1 && 
+      t1 === transformation f1 .&&. 
-      length (view accessorTo $ instruction state) == length (view accessorTo state) + 1 &&
+      length (view accessorTo $ instruction state) === length (view accessorTo state) + 1 .&&.
-      length (view accessorFrom $ instruction state) == length (view accessorFrom state) - 1 
+      length (view accessorFrom $ instruction state) === length (view accessorFrom state) - 1 
-    _ -> state == instruction state
+    _ -> 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

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 :: State -> Property
-prop_IntAdd = arithmeticTest int instructionIntAdd (+)
+prop_IntAdd = aaa1Test int instructionIntAdd (+)
 
-prop_IntSub :: State -> Bool
+prop_IntSub :: State -> Property
-prop_IntSub = arithmeticTest int instructionIntSub (-)
+prop_IntSub = aaa1Test int instructionIntSub (-)
 
-prop_IntMul :: State -> Bool
+prop_IntMul :: State -> Property
-prop_IntMul = arithmeticTest int instructionIntMul (*)
+prop_IntMul = aaa1Test int instructionIntMul (*)
 
-prop_IntDiv :: State -> Bool
+prop_IntDiv :: State -> Property
-prop_IntDiv state@(State {_int = 0 : _}) = state == instructionIntDiv state
+prop_IntDiv state@(State {_int = 0 : _}) = state === instructionIntDiv state
-prop_IntDiv state = arithmeticTest int instructionIntDiv div state
+prop_IntDiv state = aaa1Test int instructionIntDiv div state
 
-prop_IntMod :: State -> Bool
+prop_IntMod :: State -> Property
-prop_IntMod state@(State {_int = 0 : _}) = state == instructionIntMod state
+prop_IntMod state@(State {_int = 0 : _}) = state === instructionIntMod state
-prop_IntMod state = arithmeticTest int instructionIntMod mod state
+prop_IntMod state = aaa1Test int instructionIntMod mod state
 
-prop_IntFromFloat :: State -> Bool
+prop_IntFromFloat :: State -> Property
-prop_IntFromFloat = typeFromType float int instructionIntFromFloat floor
+prop_IntFromFloat = ab1Test float int instructionIntFromFloat floor
 
-prop_IntFromBool :: State -> Bool
+prop_IntFromProperty :: State -> Property
-prop_IntFromBool = typeFromType bool int instructionIntFromBool (\x -> if x then 1 else 0)
+prop_IntFromProperty = ab1Test bool int instructionIntFromBool (\x -> if x then 1 else 0)
 
-prop_IntMin :: State -> Bool
+prop_IntMin :: State -> Property
-prop_IntMin = arithmeticTest int instructionIntMin min
+prop_IntMin = aaa1Test int instructionIntMin min
 
-prop_IntMax :: State -> Bool
+prop_IntMax :: State -> Property
-prop_IntMax = arithmeticTest int instructionIntMax max
+prop_IntMax = aaa1Test int instructionIntMax max
 
-prop_IntInc :: State -> Bool
+prop_IntInc :: State -> Property
-prop_IntInc = unaryTest int instructionIntInc (+1)
+prop_IntInc = aa1Test int instructionIntInc (+1)
 
-prop_IntDec :: State -> Bool
+prop_IntDec :: State -> Property
-prop_IntDec = unaryTest int instructionIntDec (\x -> x - 1)
+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

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

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 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