diff options
| -rw-r--r-- | scratchy.cabal | 74 | ||||
| -rw-r--r-- | test/Tests.hs | 138 |
2 files changed, 157 insertions, 55 deletions
diff --git a/scratchy.cabal b/scratchy.cabal index 44a981a..9558841 100644 --- a/scratchy.cabal +++ b/scratchy.cabal @@ -1,84 +1,48 @@ cabal-version: 3.0 --- The cabal-version field refers to the version of the .cabal specification, --- and can be different from the cabal-install (the tool) version and the --- Cabal (the library) version you are using. As such, the Cabal (the library) --- version used must be equal or greater than the version stated in this field. --- Starting from the specification version 2.2, the cabal-version field must be --- the first thing in the cabal file. - --- Initial package description 'scratchy' generated by --- 'cabal init'. For further documentation, see: --- http://haskell.org/cabal/users-guide/ --- --- The name of the package. name: scratchy - --- The package version. --- See the Haskell package versioning policy (PVP) for standards --- guiding when and how versions should be incremented. --- https://pvp.haskell.org --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 1.1.0.0 - --- A short (one-line) description of the package. --- synopsis: - --- A longer description of the package. --- description: - --- The license under which the package is released. version: 1.1.0.1 license: NONE - --- The package author(s). author: Mikkel Thestrup <mithe24@student.sdu.dk> - --- An email address to which users can send suggestions, bug reports, and patches. maintainer: Mikkel Thestrup <mithe24@student.sdu.dk> - --- A copyright notice. --- copyright: category: Game build-type: Simple - --- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. extra-doc-files: CHANGELOG.md --- Extra source files to be distributed with the package, such as examples, or a tutorial module. --- extra-source-files: - common warnings ghc-options: -Wall executable scratchy - -- Import common warning flags. import: warnings - - -- .hs or .lhs file containing the Main module. main-is: Main.hs - - -- Modules included in this executable, other than Main. other-modules: Scratchy , Scratchy.Syntax , Scratchy.World , Example.CircleThatMoves , Snakey.TwoSnakes - - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: default-extensions: RecordWildCards , DeriveFunctor , LambdaCase - - -- Other library packages from which modules are imported. - build-depends: base ^>=4.18.0.0, gloss - -- Directories containing source files. + build-depends: base ^>=4.18.0.0 + , gloss + hs-source-dirs: app - -- Base language which the package is written in. + default-language: Haskell2010 + +test-suite scratchy-tests + import: warnings + type: exitcode-stdio-1.0 + main-is: Tests.hs + other-modules: Scratchy.Syntax + , Scratchy.World + + default-extensions: RecordWildCards + , DeriveFunctor + , LambdaCase + build-depends: base ^>=4.18.0.0 + , gloss + , HUnit + hs-source-dirs: test, app default-language: Haskell2010 diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 index 0000000..1fcd7be --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,138 @@ +import Test.HUnit +import Graphics.Gloss.Data.Color +import Graphics.Gloss.Data.Picture +import Graphics.Gloss.Interface.Pure.Game + +import Scratchy.Syntax + +-- Test Pure +testPure :: Test +testPure = TestCase $ do + let p = Pure () + case p of + Pure () -> return () + _ -> assertFailure "Pure should construct correctly" + +-- Test SetBackgroundColor construction +testSetBackgroundColorConstruct :: Test +testSetBackgroundColorConstruct = TestCase $ do + let p = SetBackgroundColor red (Pure ()) + case p of + SetBackgroundColor c _ -> + assertEqual "Color should be red" c red + _ -> assertFailure "SetBackgroundColor should construct correctly" + +-- Test combine SetBackgroundColor +testCombineSetBackgroundColor :: Test +testCombineSetBackgroundColor = TestCase $ do + let p1 = SetBackgroundColor red (Pure ()) + p2 = SetBackgroundColor blue (Pure ()) + combined = combine p1 p2 + case combined of + SetBackgroundColor c (SetBackgroundColor _ (Pure ())) -> + assertEqual "First color should be red" c red + _ -> assertFailure "combine should nest SetBackgroundColor correctly" + +-- Test NewSprite construction +testNewSpriteConstruct :: Test +testNewSpriteConstruct = TestCase $ do + let p = NewSprite (5, 5) (circleSolid 10) (\_ -> Pure ()) + case p of + NewSprite cell _ _ -> do + assertEqual "Cell should be (5, 5)" cell (5, 5) + _ -> assertFailure "NewSprite should construct correctly" + +-- Test OnKeyEvent construction +testOnKeyEventConstruct :: Test +testOnKeyEventConstruct = TestCase $ do + let p = OnKeyEvent (SpecialKey KeyDown) (Pure ()) (Pure ()) + case p of + OnKeyEvent key _ _ -> + assertEqual "Key should be KeyDown" key (SpecialKey KeyDown) + _ -> assertFailure "OnKeyEvent should construct correctly" + +-- Test OnTargetReached construction +testOnTargetReachedConstruct :: Test +testOnTargetReachedConstruct = TestCase $ do + let p = OnTargetReached 0 (\_ -> Pure ()) (Pure ()) + case p of + OnTargetReached ptr _ _ -> + assertEqual "Sprite pointer should be 0" ptr 0 + _ -> assertFailure "OnTargetReached should construct correctly" + +-- Test After (timer) construction +testAfterConstruct :: Test +testAfterConstruct = TestCase $ do + let p = After 10 (Pure ()) (Pure ()) + case p of + After dur _ _ -> + assertEqual "Duration should be 10" dur 10 + _ -> assertFailure "After should construct correctly" + +-- Test InspectCell construction +testInspectCellConstruct :: Test +testInspectCellConstruct = TestCase $ do + let p = InspectCell (0, 0) (\case + IsFree -> Pure () + _ -> Pure ()) + case p of + InspectCell cell _ -> + assertEqual "Cell should be (0, 0)" cell (0, 0) + _ -> assertFailure "InspectCell should construct correctly" + +-- Test combine nesting +testCombineNesting :: Test +testCombineNesting = TestCase $ do + let p1 = SetBackgroundColor red (Pure ()) + p2 = SetBackgroundColor blue (Pure ()) + p3 = SetBackgroundColor green (Pure ()) + combined = combine p1 (combine p2 p3) + case combined of + SetBackgroundColor _ _ -> return () + _ -> assertFailure "combine should nest correctly" + +-- Test dirVec +testDirVec :: Test +testDirVec = TestCase $ do + assertEqual "dirVec U" (dirVec U) (0, 1) + assertEqual "dirVec D" (dirVec D) (0, -1) + assertEqual "dirVec L" (dirVec L) (-1, 0) + assertEqual "dirVec R" (dirVec R) (1, 0) + +-- Test nextCell +testNextCell :: Test +testNextCell = TestCase $ do + assertEqual "nextCell U (0,0)" (nextCell U (0, 0)) (0, 1) + assertEqual "nextCell D (5,5)" (nextCell D (5, 5)) (5, 4) + assertEqual "nextCell L (3,3)" (nextCell L (3, 3)) (2, 3) + assertEqual "nextCell R (2,2)" (nextCell R (2, 2)) (3, 2) + +-- Test inBounds +testInBounds :: Test +testInBounds = TestCase $ do + assertBool "Center should be in bounds" (inBounds (15, 15)) + assertBool "(0, 0) should be in bounds" (inBounds (0, 0)) + assertBool "(29, 29) should be in bounds" (inBounds (29, 29)) + assertBool "(-1, 0) should be out of bounds" (not (inBounds (-1, 0))) + assertBool "(30, 15) should be out of bounds" (not (inBounds (30, 15))) + assertBool "(15, -1) should be out of bounds" (not (inBounds (15, -1))) + +-- Run all tests +allTests :: Test +allTests = TestList + [ TestLabel "Pure" testPure + , TestLabel "SetBackgroundColorConstruct" testSetBackgroundColorConstruct + , TestLabel "CombineSetBackgroundColor" testCombineSetBackgroundColor + , TestLabel "NewSpriteConstruct" testNewSpriteConstruct + , TestLabel "OnKeyEventConstruct" testOnKeyEventConstruct + , TestLabel "OnTargetReachedConstruct" testOnTargetReachedConstruct + , TestLabel "AfterConstruct" testAfterConstruct + , TestLabel "InspectCellConstruct" testInspectCellConstruct + , TestLabel "CombineNesting" testCombineNesting + , TestLabel "DirVec" testDirVec + , TestLabel "NextCell" testNextCell + , TestLabel "InBounds" testInBounds + ] + +main :: IO () +main = runTestTT allTests >> return () |