Refactor test interface (#100)

* Monad stack for tests

* Use ReaderT to distribute picture/animation

* Throw errors with Except

* add new functions for animation and picture tests

* adjust examples

Author: patritzenfeld

examples/configs/Task01.hs

@@ -185,7 +185,7 @@ main = drawingOf scene
 ----------
 module Test (test) where
 import qualified Task01
-import Test.HUnit ((~:), (~?), Test)
+import Test.HUnit ((~:), Test(..), assertString)
 import CodeWorld.Test (
   withColor,
   green,
@@ -194,27 +194,29 @@ import CodeWorld.Test (
   yellow,
 
   containsElem,
-  evaluatePred,
   hasRelation,
   isAbove,
+
+  complain,
+  testPicture,
   )
 
 import TestHelper (isDeeplyDefined)
 
 test :: [ Test ]
 test =
   [ "scene =/= undefined?" ~: isDeeplyDefined Task01.scene
-  , onScene (containsElem someSolidCircle) ~?
-    "This picture does not contain a solid circle."
-  , onScene (containsElem someSolidRectangle) ~?
-    "This picture does not contain a solid rectangle."
-  , onScene (containsElem $ withColor yellow someSolidCircle) ~?
-    "The circle is not yellow."
-  , onScene (containsElem $ withColor green someSolidRectangle) ~?
-    "The rectangle is not green."
-  , onScene (hasRelation $ withColor yellow someSolidCircle `isAbove` withColor green someSolidRectangle) ~?
-    "the sun should be positioned above the grass."
+  , TestCase $ assertString $ testPicture Task01.scene $ do
+      complain "This picture does not contain a solid circle."
+        $ containsElem someSolidCircle
+      complain "This picture does not contain a solid rectangle."
+        $ containsElem someSolidRectangle
+      complain "The circle is not yellow."
+        $ containsElem $ withColor yellow someSolidCircle
+      complain "The rectangle is not green."
+        $ containsElem $ withColor green someSolidRectangle
+      complain "the sun should be positioned above the grass."
+        $ hasRelation $ withColor yellow someSolidCircle `isAbove` withColor green someSolidRectangle
   ]
-  where
-    onScene = flip evaluatePred Task01.scene
+
 

examples/configs/Task02.hs

@@ -185,7 +185,12 @@ scene = undefined
 ----------
 module Test (test) where
 import qualified Task02
-import Test.HUnit ((~:), (~?), Assertion, Test(..), assertBool)
+import Test.HUnit (
+  (~:),
+  Test(..),
+  assertBool,
+  assertString,
+  )
 import CodeWorld.Test (
   brown,
   green,
@@ -198,13 +203,15 @@ import CodeWorld.Test (
 
   atLeast,
   containsElem,
-  evaluatePred,
-  evaluatePreds,
   hasRelation,
   ifThen,
   isAbove,
   isLeftOf,
   isNorthOf,
+  (<&&>),
+
+  complain,
+  testPicture,
 
   testCSE,
   )
@@ -215,32 +222,30 @@ import TestHelper (isDeeplyDefined)
 test :: [ Test ]
 test =
   [ "scene =/= undefined?" ~: isDeeplyDefined Task02.scene
-  , onScene (containsElem wood) ~?
-    "Picture contains a trunk?"
-  , onScene (wood `atLeast` 3) ~?
-    "Tree has at least a trunk and two branches?"
-  , onScene (containsElem $ withColor green someSolidCircle) ~?
-    "Tree has a green crown?"
-  , onScene (hasRelation $ withColor green someSolidCircle `isNorthOf` uprightWood) ~?
-    "The trunk stands upright and there is a tree crown above it?"
-  , onSceneMulti
-      [ containsElem (rotatedQuarter uprightWood) `ifThen` containsElem (rotatedUpToFull uprightWood)
-      , containsElem (rotatedUpToFull uprightWood) `ifThen` containsElem (rotatedQuarter uprightWood)
-      ] ~?
-    "Branches are roughly symmetrical? (if they already are, make sure your branches share code as much as possible)"
-  , onSceneMulti
-      [ hasRelation $ rotatedQuarter uprightWood `isAbove` uprightWood
-      , hasRelation $ rotatedUpToFull uprightWood `isAbove` uprightWood
-      , hasRelation $ rotatedQuarter uprightWood `isLeftOf` rotatedUpToFull uprightWood
-      ] ~?
-    "Branches are in the correct position? " ++
-    "(They should neither cross, nor be detached from the trunk, nor be at level with the trunk)"
+  , TestCase $ assertString $ testPicture Task02.scene $ do
+      complain "Picture contains a trunk?" $ containsElem wood
+      complain "Tree has at least a trunk and two branches?" $ wood `atLeast` 3
+      complain "Tree has a green crown?" $ containsElem $ withColor green someSolidCircle
+      complain "The trunk stands upright and there is a tree crown above it?"
+        $ hasRelation $ withColor green someSolidCircle `isNorthOf` uprightWood
+      complain
+        ( "Branches are roughly symmetrical? " ++
+          "(if they already are, make sure your branches share code as much as possible)"
+        )
+        $ containsElem (rotatedQuarter uprightWood) `ifThen` containsElem (rotatedUpToFull uprightWood) <&&>
+          containsElem (rotatedUpToFull uprightWood) `ifThen` containsElem (rotatedQuarter uprightWood)
+      complain
+        ( "Branches are in the correct position? " ++
+          "(They should neither cross, nor be detached from the trunk, nor be at level with the trunk)"
+        )
+        $ hasRelation (rotatedQuarter uprightWood `isAbove` uprightWood) <&&>
+          hasRelation (rotatedUpToFull uprightWood `isAbove` uprightWood) <&&>
+          hasRelation (rotatedQuarter uprightWood `isLeftOf` rotatedUpToFull uprightWood)
+
   , TestCase $ do
       result <- testCSE Task02.scene
       assertBool (fromJust result) (isNothing result)
   ]
   where
-    onScene = flip evaluatePred Task02.scene
-    onSceneMulti = flip evaluatePreds Task02.scene
     wood = withColor brown someSolidRectangle
     uprightWood = withColor brown someTallSolidRectangle

examples/configs/Task03.hs

@@ -188,7 +188,7 @@ scene = undefined
 ----------
 module Test (test) where
 import qualified Task03
-import Test.HUnit ((~:), (~?), Test)
+import Test.HUnit ((~:), Test(..), assertString)
 import CodeWorld.Test (
   (.&.),
   withColor,
@@ -199,45 +199,47 @@ import CodeWorld.Test (
   white,
   yellow,
 
-  findMaybe,
-  getComponents,
+  findAllAnd,
   getExactScalingFactors,
   contains,
 
   (<||>),
   atSamePosition,
   containsElem,
-  evaluatePred,
   hasRelation,
   isBelow,
   oneOf,
-  )
 
+  complain,
+  testPicture,
+  )
 import TestHelper (isDeeplyDefined)
 
 test :: [ Test ]
 test =
   [ "scene =/= undefined?" ~: isDeeplyDefined Task03.scene
-  , onScene (containsElem yolk) ~?
-    "The picture does not contain the yellow yolk."
-  , onScene (oneOf containsElem [someCircle, solidWhite, polyEgg]) ~?
-    "The picture does not contain the egg white."
-  , onScene (oneOf containsElem [egg, solidGray, multiEgg, polyEgg]) ~?
-    "The shell could not be found. It might have the wrong color (should be grey) " ++
-    "or might not be a continuous, round shape."
-  , any (uncurry (<) . scalingFactor) [egg,solidGray] ||
-    onScene (containsElem polyEgg) ~?
-    "The egg shell does not seem to have an oval shape."
-  , onScene ( oneOf (\p ->
-      hasRelation (yolk `atSamePosition` p) <||>
-      hasRelation (yolk `isBelow` p)) [egg, multiEgg, polyEgg]
-      ) ~?  "The yolk is not inside the egg or has not been positioned correctly inside it."
+  , TestCase $ assertString $ testPicture Task03.scene $ do
+      complain "The picture does not contain the yellow yolk."
+        $ containsElem yolk
+      complain "The picture does not contain the egg white."
+        $ oneOf containsElem [someCircle, solidWhite, polyEgg]
+      complain
+        ( "The shell could not be found. It might have the wrong color (should be grey) " ++
+          "or might not be a continuous, round shape."
+        )
+        $ oneOf containsElem [egg, solidGray, multiEgg, polyEgg]
+      complain "The egg shell does not seem to have an oval shape." $ do
+        circleEggs <- findAllAnd
+          ((||) <$> (`contains` egg) <*> (`contains` solidGray))
+          getExactScalingFactors
+        pure (any (uncurry (<)) circleEggs) <||> containsElem polyEgg
+      complain "The yolk is not inside the egg or has not been positioned correctly inside it."
+        $ oneOf (\p ->
+            hasRelation (yolk `atSamePosition` p) <||>
+            hasRelation (yolk `isBelow` p)
+            ) [egg, multiEgg, polyEgg]
   ]
   where
-    onScene = flip evaluatePred Task03.scene
-    scalingFactor p = maybe (1,1) getExactScalingFactors $
-      findMaybe (`contains` p) $ getComponents Task03.scene
-
     egg = withColor gray someCircle
     multiEgg = solidGray .&. solidWhite
     polyEgg = withColor gray (someCurve 4)

examples/configs/Task04.hs

@@ -236,12 +236,14 @@ truncatedTime t =
   let (n,f) = properFraction t
   in show (n :: Int) ++ take 3 (tail (show f))
 ----------
+{-# language NoMonomorphismRestriction #-}
+
 module Test (test) where
 import qualified Task04
-
+import Data.Maybe (isNothing)
 import Data.List.Extra (nubOrd)
-import Data.Tuple.Extra (both)
-import Test.HUnit ((~:), (~?), Test(..), assertBool)
+import Data.Tuple.Extra ((&&&))
+import Test.HUnit ((~:), Test(..), assertBool, assertString)
 import CodeWorld.Test (
   withColor,
   green,
@@ -251,48 +253,67 @@ import CodeWorld.Test (
   yellow,
 
   contains,
-  findMaybeActual,
-  getComponents,
+  findMaybeActualAnd,
   getExactTranslation,
   getRotation,
 
   containsElem,
-  evaluatePred,
   hasRelation,
   isBelow,
 
+  atTime,
+  noneAt,
+  rawImagesAt,
+  queryAt,
+
+  complain,
+  testAnimation,
+  testPicture,
+
   samplesUntil,
   )
-
+import Control.Monad.Reader
 import qualified TestHarness as TH
 import TestHelper (isDeeplyDefined)
 
 test :: [ Test ]
 test =
   [ "scene =/= undefined?" ~: isDeeplyDefined (Task04.scene 1.0)
-  , onSceneAt 0 (containsElem someSolidCircle) ~?
-    "This animation does not contain a solid circle."
-  , onSceneAt 0 (containsElem someSolidRectangle) ~?
-    "This animation does not contain a solid rectangle."
-  , onSceneAt 0 (containsElem sun) ~?
-    "The circle is not yellow."
-  , onSceneAt 0 (containsElem grass) ~?
-    "The rectangle is not green."
-  , grassRotations (100 : frames) == 1 &&
-    grassMovement (100 : frames)  == 1 ~?
-    "The grass seems to move or disappear at some point during this animation. " ++
-    "It should be stationary and the sun should move instead."
-  , not (onSceneAt 0 (containsElem cheat)) ~?
-    "The scene contains a solid white rectangle. " ++
-    "This suggests you are trying to conceal the movement of the sun at some point."
-  , differentFrames (map (+100) frames) == 1 ~?
-    "Your animation has changing frames after running for 100 seconds. " ++
-    "This suggests your sun is permanently moving instead of setting at some point."
-  , differentFrames frames > 1 ~?
-    "Cannot detect (reasonable) movement in this animation. Make sure parameter 't' is not ignored. " ++
-    "Your sun might be moving in a strange way if 't' is actually used for movement."
-  , all (\t -> not $ onSceneAt t (hasRelation (sun `isBelow` grass))) (samplesUntil 0.5 30) ~?
-    "Your sun is moving under the grass!"
+  , TestCase $ assertString $ testAnimation Task04.scene $ do
+      atTime 0 $ do
+        complain "This animation does not contain a solid circle."
+          $ containsElem someSolidCircle
+        complain "This animation does not contain a solid rectangle."
+          $ containsElem someSolidRectangle
+        complain "The circle is not yellow." $ containsElem sun
+        complain "The rectangle is not green." $ containsElem grass
+        complain
+          ( "The scene contains a solid white rectangle. " ++
+            "This suggests you are trying to conceal the movement of the sun at some point."
+          )
+          $ not <$> containsElem cheat
+
+      complain
+        ( "The grass seems to move or disappear at some point during this animation. " ++
+          "It should be stationary and the sun should move instead."
+        )
+        $ (==1) . uniques <$> queryAt (100 : frames) getGrassValues
+
+      complain
+        ( "Your animation has changing frames after running for 100 seconds. " ++
+          "This suggests your sun is permanently moving instead of setting at some point."
+        )
+        $ (==1) . uniques <$> rawImagesAt (map (+100) frames)
+
+      complain
+        ( "Cannot detect (reasonable) movement in this animation. Make sure parameter 't' is not ignored. " ++
+          "Your sun might be moving in a strange way if 't' is actually used for movement."
+        )
+        $ (>1) . uniques <$> rawImagesAt frames
+
+      complain "Your sun is moving under the grass!"
+        $ noneAt (samplesUntil 0.5 30) $ hasRelation $ sun `isBelow` grass
+
   , TestCase $ TH.syntaxCheckWithExts ["LambdaCase","NoTemplateHaskell","TupleSections"] $ \m -> assertBool
       ( "The sun is not exhibiting circular movement. " ++
         "Please make sure it is not following a parabola shape or other different motions."
@@ -303,13 +324,7 @@ test =
     frames = samplesUntil 0.2 5
     grass = withColor green someSolidRectangle
     cheat = withColor white someSolidRectangle
-    onSceneAt t = flip evaluatePred (Task04.scene t)
-    sceneAt = getComponents . Task04.scene
-    mapUniques f = length . nubOrd . map f
-    differentFrames = mapUniques Task04.scene
-    getElementAt p = findMaybeActual (`contains` p) . Task04.scene
-    rotationAt p t = getRotation <$> getElementAt p t
-    grassRotations = mapUniques $ rotationAt grass
-    grassMovement = mapUniques (fmap getExactTranslation . getElementAt grass)
+    uniques = length . nubOrd
+    getGrassValues = findMaybeActualAnd (`contains` grass)
+      $ getRotation &&& getExactTranslation
     sun = withColor yellow someSolidCircle
-