diff options
author | Griffin Smith <grfn@gws.fyi> | 2021-04-11T21·53-0400 |
---|---|---|
committer | glittershark <grfn@gws.fyi> | 2021-04-12T14·45+0000 |
commit | 6266c5d32f9ff651fcfc3a4cc0c68e89da56ca65 (patch) | |
tree | 5be3967585787c4456e17cb29423770217fdcede /users/glittershark/xanthous/test | |
parent | 968effb5dc1a4617a0dceaffc70e986abe300c6e (diff) |
refactor(users/glittershark): Rename to grfn r/2485
Rename my //users directory and all places that refer to glittershark to grfn, including nix references and documentation. This may require some extra attention inside of gerrit's database after it lands to allow me to actually push things. Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933 Tested-by: BuildkiteCI Reviewed-by: tazjin <mail@tazj.in> Reviewed-by: lukegb <lukegb@tvl.fyi> Reviewed-by: glittershark <grfn@gws.fyi>
Diffstat (limited to 'users/glittershark/xanthous/test')
20 files changed, 0 insertions, 934 deletions
diff --git a/users/glittershark/xanthous/test/Spec.hs b/users/glittershark/xanthous/test/Spec.hs deleted file mode 100644 index f15c393ac917..000000000000 --- a/users/glittershark/xanthous/test/Spec.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Xanthous.Data.EntitiesSpec -import qualified Xanthous.Data.EntityCharSpec -import qualified Xanthous.Data.EntityMap.GraphicsSpec -import qualified Xanthous.Data.EntityMapSpec -import qualified Xanthous.Data.LevelsSpec -import qualified Xanthous.Data.NestedMapSpec -import qualified Xanthous.DataSpec -import qualified Xanthous.Entities.RawsSpec -import qualified Xanthous.GameSpec -import qualified Xanthous.Generators.UtilSpec -import qualified Xanthous.MessageSpec -import qualified Xanthous.Messages.TemplateSpec -import qualified Xanthous.OrphansSpec -import qualified Xanthous.RandomSpec -import qualified Xanthous.Util.GraphSpec -import qualified Xanthous.Util.GraphicsSpec -import qualified Xanthous.Util.InflectionSpec -import qualified Xanthous.UtilSpec --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous" - [ Xanthous.Data.EntitiesSpec.test - , Xanthous.Data.EntityMap.GraphicsSpec.test - , Xanthous.Data.EntityMapSpec.test - , Xanthous.Data.LevelsSpec.test - , Xanthous.Data.NestedMapSpec.test - , Xanthous.DataSpec.test - , Xanthous.Entities.RawsSpec.test - , Xanthous.GameSpec.test - , Xanthous.Generators.UtilSpec.test - , Xanthous.MessageSpec.test - , Xanthous.Messages.TemplateSpec.test - , Xanthous.OrphansSpec.test - , Xanthous.RandomSpec.test - , Xanthous.Util.GraphSpec.test - , Xanthous.Util.GraphicsSpec.test - , Xanthous.Util.InflectionSpec.test - , Xanthous.UtilSpec.test - , Xanthous.Data.EntityCharSpec.test - ] diff --git a/users/glittershark/xanthous/test/Test/Prelude.hs b/users/glittershark/xanthous/test/Test/Prelude.hs deleted file mode 100644 index c423796184f7..000000000000 --- a/users/glittershark/xanthous/test/Test/Prelude.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Test.Prelude - ( module Xanthous.Prelude - , module Test.Tasty - , module Test.Tasty.HUnit - , module Test.Tasty.QuickCheck - , module Test.QuickCheck.Classes - , testBatch - ) where - -import Xanthous.Prelude hiding (assert, elements) -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -import Test.QuickCheck.Classes -import Test.QuickCheck.Checkers (TestBatch) -import Test.QuickCheck.Instances.ByteString () - -testBatch :: TestBatch -> TestTree -testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs deleted file mode 100644 index e403503743c0..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntitiesSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntitiesSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Data.Aeson as JSON --------------------------------------------------------------------------------- -import Xanthous.Data.Entities --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.Entities" - [ testGroup "Collision" - [ testProperty "JSON round-trip" $ \(c :: Collision) -> - JSON.decode (JSON.encode c) === Just c - , testGroup "JSON encoding examples" - [ testCase "Stop" $ JSON.encode Stop @?= "\"Stop\"" - , testCase "Combat" $ JSON.encode Combat @?= "\"Combat\"" - ] - ] - , testGroup "EntityAttributes" - [ testProperty "JSON round-trip" $ \(ea :: EntityAttributes) -> - JSON.decode (JSON.encode ea) === Just ea - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs deleted file mode 100644 index 9e8024c9d223..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntityCharSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntityCharSpec where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Data.Aeson as JSON --------------------------------------------------------------------------------- -import Xanthous.Data.EntityChar --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.EntityChar" - [ testProperty "JSON round-trip" $ \(ec :: EntityChar) -> - JSON.decode (JSON.encode ec) === Just ec - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs deleted file mode 100644 index fd37548ce864..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap.GraphicsSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Data.Aeson --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Data -import Xanthous.Data.EntityMap -import Xanthous.Data.EntityMap.Graphics -import Xanthous.Entities.Environment (Wall(..)) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.EntityMap.Graphics" - [ testGroup "visiblePositions" - [ testProperty "one step in each cardinal direction is always visible" - $ \pos (Cardinal dir) (Positive r) (wallPositions :: Set Position)-> - pos `notMember` wallPositions ==> - let em = review _EntityMap . map (, Wall) . toList $ wallPositions - em' = em & atPosition (move dir pos) %~ (Wall <|) - poss = visiblePositions pos r em' - in counterexample ("visiblePositions: " <> show poss) - $ move dir pos `member` poss - , testGroup "bugs" - [ testCase "non-contiguous bug 1" - $ let charPos = Position 20 20 - gormlakPos = Position 17 19 - em = insertAt gormlakPos TestEntity - . insertAt charPos TestEntity - $ mempty - visPositions = visiblePositions charPos 12 em - in (gormlakPos `member` visPositions) @? - ( "not (" - <> show gormlakPos <> " `member` " - <> show visPositions - <> ")" - ) - ] - ] - ] - --------------------------------------------------------------------------------- - -data TestEntity = TestEntity - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (ToJSON, FromJSON, NFData) - -instance Brain TestEntity where - step _ = pure -instance Draw TestEntity -instance Entity TestEntity where - description _ = "" - entityChar _ = "e" diff --git a/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs deleted file mode 100644 index 7c5cad019616..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/EntityMapSpec.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMapSpec where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Data.Aeson as JSON --------------------------------------------------------------------------------- -import Xanthous.Data.EntityMap -import Xanthous.Data (Positioned(..)) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = localOption (QuickCheckTests 20) - $ testGroup "Xanthous.Data.EntityMap" - [ testBatch $ monoid @(EntityMap Int) mempty - , testGroup "Deduplicate" - [ testGroup "Semigroup laws" - [ testProperty "associative" $ \(a :: Deduplicate (EntityMap Int)) b c -> - a <> (b <> c) === (a <> b) <> c - ] - ] - , testGroup "Eq laws" - [ testProperty "reflexivity" $ \(em :: EntityMap Int) -> - em == em - , testProperty "symmetric" $ \(em₁ :: EntityMap Int) em₂ -> - (em₁ == em₂) == (em₂ == em₁) - , testProperty "transitive" $ \(em₁ :: EntityMap Int) em₂ em₃ -> - if (em₁ == em₂ && em₂ == em₃) - then (em₁ == em₃) - else True - ] - , testGroup "JSON encoding/decoding" - [ testProperty "round-trips" $ \(em :: EntityMap Int) -> - let em' = JSON.decode (JSON.encode em) - in counterexample (show (em' ^? _Just . lastID, em ^. lastID - , em' ^? _Just . byID == em ^. byID . re _Just - , em' ^? _Just . byPosition == em ^. byPosition . re _Just - , em' ^? _Just . _EntityMap == em ^. _EntityMap . re _Just - )) - $ em' === Just em - , testProperty "Preserves IDs" $ \(em :: EntityMap Int) -> - let Just em' = JSON.decode $ JSON.encode em - in toEIDsAndPositioned em' === toEIDsAndPositioned em - ] - - , localOption (QuickCheckTests 50) - $ testGroup "atPosition" - [ testProperty "setget" $ \pos (em :: EntityMap Int) es -> - view (atPosition pos) (set (atPosition pos) es em) === es - , testProperty "getset" $ \pos (em :: EntityMap Int) -> - set (atPosition pos) (view (atPosition pos) em) em === em - , testProperty "setset" $ \pos (em :: EntityMap Int) es -> - (set (atPosition pos) es . set (atPosition pos) es) em - === - set (atPosition pos) es em - -- testProperty "lens laws" $ \pos -> isLens $ atPosition @Int pos - , testProperty "preserves IDs" $ \(em :: EntityMap Int) e1 e2 p -> - let (eid, em') = insertAtReturningID p e1 em - em'' = em' & atPosition p %~ (e2 <|) - in - counterexample ("em': " <> show em') - . counterexample ("em'': " <> show em'') - $ em'' ^. at eid === Just (Positioned p e1) - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs deleted file mode 100644 index 4e46946a93b0..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/LevelsSpec.hs +++ /dev/null @@ -1,66 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.LevelsSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import qualified Data.Aeson as JSON --------------------------------------------------------------------------------- -import Xanthous.Util (between) -import Xanthous.Data.Levels --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.Levels" - [ testGroup "current" - [ testProperty "view is extract" $ \(levels :: Levels Int) -> - levels ^. current === extract levels - , testProperty "set replaces current" $ \(levels :: Levels Int) new -> - extract (set current new levels) === new - , testProperty "set extract is id" $ \(levels :: Levels Int) -> - set current (extract levels) levels === levels - , testProperty "set y ∘ set x ≡ set y" $ \(levels :: Levels Int) x y -> - set current y (set current x levels) === set current y levels - ] - , localOption (QuickCheckTests 20) - $ testBatch $ semigroup @(Levels Int) (error "unused", 1 :: Int) - , testGroup "next/prev" - [ testGroup "nextLevel" - [ testProperty "seeks forwards" $ \(levels :: Levels Int) genned -> - (pos . runIdentity . nextLevel (Identity genned) $ levels) - === pos levels + 1 - , testProperty "maintains the invariant" $ \(levels :: Levels Int) genned -> - let levels' = runIdentity . nextLevel (Identity genned) $ levels - in between 0 (length levels') $ pos levels' - , testProperty "extract is total" $ \(levels :: Levels Int) genned -> - let levels' = runIdentity . nextLevel (Identity genned) $ levels - in total $ extract levels' - , testProperty "uses the generated level as the next level" - $ \(levels :: Levels Int) genned -> - let levels' = seek (length levels - 1) levels - levels'' = runIdentity . nextLevel (Identity genned) $ levels' - in counterexample (show levels'') - $ extract levels'' === genned - ] - , testGroup "prevLevel" - [ testProperty "seeks backwards" $ \(levels :: Levels Int) -> - case prevLevel levels of - Nothing -> property Discard - Just levels' -> pos levels' === pos levels - 1 - , testProperty "maintains the invariant" $ \(levels :: Levels Int) -> - case prevLevel levels of - Nothing -> property Discard - Just levels' -> property $ between 0 (length levels') $ pos levels' - , testProperty "extract is total" $ \(levels :: Levels Int) -> - case prevLevel levels of - Nothing -> property Discard - Just levels' -> total $ extract levels' - ] - ] - , testGroup "JSON" - [ testProperty "toJSON/parseJSON round-trip" $ \(levels :: Levels Int) -> - JSON.decode (JSON.encode levels) === Just levels - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs deleted file mode 100644 index acf7a67268f4..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Data/NestedMapSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.NestedMapSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck.Instances.Semigroup () --------------------------------------------------------------------------------- -import qualified Xanthous.Data.NestedMap as NM --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.NestedMap" - [ testProperty "insert/lookup" $ \nm ks v -> - let nm' = NM.insert ks v nm - in counterexample ("inserted: " <> show nm') - $ NM.lookup @Map @Int @Int ks nm' === Just (NM.Val v) - ] diff --git a/users/glittershark/xanthous/test/Xanthous/DataSpec.hs b/users/glittershark/xanthous/test/Xanthous/DataSpec.hs deleted file mode 100644 index 91dc6cea1ba5..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/DataSpec.hs +++ /dev/null @@ -1,98 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.DataSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude hiding (Right, Left, Down, toList, all) -import Data.Group -import Data.Foldable (toList, all) --------------------------------------------------------------------------------- -import Xanthous.Data --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data" - [ testGroup "Position" - [ testBatch $ monoid @Position mempty - , testProperty "group laws" $ \(pos :: Position) -> - pos <> invert pos == mempty && invert pos <> pos == mempty - , testGroup "stepTowards laws" - [ testProperty "takes only one step" $ \src tgt -> - src /= tgt ==> - isUnit (src `diffPositions` (src `stepTowards` tgt)) - -- , testProperty "moves in the right direction" $ \src tgt -> - -- stepTowards src tgt == move (directionOf src tgt) src - ] - , testProperty "directionOf laws" $ \pos dir -> - directionOf pos (move dir pos) == dir - , testProperty "diffPositions is add inverse" $ \(pos₁ :: Position) pos₂ -> - diffPositions pos₁ pos₂ == addPositions pos₁ (invert pos₂) - , testGroup "isUnit" - [ testProperty "double direction is never unit" $ \dir -> - not . isUnit $ move dir (asPosition dir) - , testCase "examples" $ do - isUnit (Position @Int 1 1) @? "not . isUnit $ Position 1 1" - isUnit (Position @Int 0 (-1)) @? "not . isUnit $ Position 0 (-1)" - (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13" - ] - ] - - , testGroup "Direction" - [ testProperty "opposite is involutive" $ \(dir :: Direction) -> - opposite (opposite dir) == dir - , testProperty "opposite provides inverse" $ \dir -> - invert (asPosition dir) === asPosition (opposite dir) - , testProperty "asPosition isUnit" $ \dir -> - dir /= Here ==> isUnit (asPosition dir) - , testGroup "Move" - [ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1) - , testCase "Down" $ move Down mempty @?= Position @Int 0 1 - , testCase "Left" $ move Left mempty @?= Position @Int (-1) 0 - , testCase "Right" $ move Right mempty @?= Position @Int 1 0 - , testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1) - , testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1) - , testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1 - , testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1 - ] - ] - - , testGroup "Corner" - [ testGroup "instance Opposite" - [ testProperty "involutive" $ \(corner :: Corner) -> - opposite (opposite corner) === corner - ] - ] - - , testGroup "Edge" - [ testGroup "instance Opposite" - [ testProperty "involutive" $ \(edge :: Edge) -> - opposite (opposite edge) === edge - ] - ] - - , testGroup "Box" - [ testGroup "boxIntersects" - [ testProperty "True" $ \dims -> - boxIntersects (Box @Word (V2 1 1) (V2 2 2)) - (Box (V2 2 2) dims) - , testProperty "False" $ \dims -> - not $ boxIntersects (Box @Word (V2 1 1) (V2 2 2)) - (Box (V2 4 2) dims) - ] - ] - - , testGroup "Neighbors" - [ testGroup "rotations" - [ testProperty "always has the same members" - $ \(neighs :: Neighbors Int) -> - all (\ns -> sort (toList ns) == sort (toList neighs)) - $ rotations neighs - , testProperty "all rotations have the same rotations" - $ \(neighs :: Neighbors Int) -> - let rots = rotations neighs - in all (\ns -> sort (toList $ rotations ns) == sort (toList rots)) - rots - ] - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs deleted file mode 100644 index 2e6f35457fc7..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Entities/RawsSpec.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | - -module Xanthous.Entities.RawsSpec (main, test) where - -import Test.Prelude -import Xanthous.Entities.Raws - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.Raws" - [ testGroup "raws" - [ testCase "are all valid" $ raws `deepseq` pure () - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/GameSpec.hs b/users/glittershark/xanthous/test/Xanthous/GameSpec.hs deleted file mode 100644 index 2fa8527d0e59..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/GameSpec.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Xanthous.GameSpec where - -import Test.Prelude hiding (Down) -import Xanthous.Game -import Xanthous.Game.State -import Control.Lens.Properties -import Xanthous.Data (move, Direction(Down)) -import Xanthous.Data.EntityMap (atPosition) - -main :: IO () -main = defaultMain test - -test :: TestTree -test - = localOption (QuickCheckTests 10) - . localOption (QuickCheckMaxSize 10) - $ testGroup "Xanthous.Game" - [ testGroup "positionedCharacter" - [ testProperty "lens laws" $ isLens positionedCharacter - , testCase "updates the position of the character" $ do - initialGame <- getInitialState - let initialPos = initialGame ^. characterPosition - updatedGame = initialGame & characterPosition %~ move Down - updatedPos = updatedGame ^. characterPosition - updatedPos @?= move Down initialPos - updatedGame ^. entities . atPosition initialPos @?= fromList [] - updatedGame ^. entities . atPosition updatedPos - @?= fromList [SomeEntity $ initialGame ^. character] - ] - , testGroup "characterPosition" - [ testProperty "lens laws" $ isLens characterPosition - ] - , testGroup "character" - [ testProperty "lens laws" $ isLens character - ] - , testGroup "MessageHistory" - [ testGroup "MonoComonad laws" - [ testProperty "oextend oextract ≡ id" - $ \(mh :: MessageHistory) -> oextend oextract mh === mh - , testProperty "oextract ∘ oextend f ≡ f" - $ \(mh :: MessageHistory) f -> (oextract . oextend f) mh === f mh - , testProperty "oextend f ∘ oextend g ≡ oextend (f . oextend g)" - $ \(mh :: MessageHistory) f g -> - (oextend f . oextend g) mh === oextend (f . oextend g) mh - ] - ] - , testGroup "Saving the game" - [ testProperty "forms a prism" $ isPrism saved - , testProperty "round-trips" $ \gs -> - loadGame (saveGame gs) === Just gs - , testProperty "preserves the character ID" $ \gs -> - let Just gs' = loadGame $ saveGame gs - in gs' ^. character === gs ^. character - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs b/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs deleted file mode 100644 index cdfadc06f505..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE PackageImports #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.UtilSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import System.Random (mkStdGen) -import Control.Monad.Random (runRandT) -import Data.Array.ST (STUArray, runSTUArray, thaw) -import Data.Array.IArray (bounds) -import Data.Array.MArray (newArray, readArray, writeArray) -import Data.Array (Array, range, listArray, Ix) -import Control.Monad.ST (ST, runST) -import "checkers" Test.QuickCheck.Instances.Array () -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util -import Xanthous.Data (width, height) -import Xanthous.Generators.Util --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - --------------------------------------------------------------------------------- - -newtype GenArray a b = GenArray (Array a b) - deriving stock (Show, Eq) - -instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) - => Arbitrary (GenArray a b) where - arbitrary = GenArray <$> do - (mkElem :: a -> b) <- arbitrary - minDims <- arbitrary - maxDims <- arbitrary - let bnds = (minDims, maxDims) - pure $ listArray bnds $ mkElem <$> range bnds - -test :: TestTree -test = testGroup "Xanthous.Generators.Util" - [ testGroup "randInitialize" - [ testProperty "returns an array of the correct dimensions" - $ \dims seed aliveChance -> - let gen = mkStdGen seed - res = runSTUArray - $ fmap fst - $ flip runRandT gen - $ randInitialize dims aliveChance - in bounds res === (0, V2 (dims ^. width) (dims ^. height)) - ] - , testGroup "numAliveNeighborsM" - [ testProperty "maxes out at 8" - $ \(GenArray (arr :: Array (V2 Word) Bool)) loc -> - let - act :: forall s. ST s Word - act = do - mArr <- thaw @_ @_ @_ @(STUArray s) arr - numAliveNeighborsM mArr loc - res = runST act - in counterexample (show res) $ between 0 8 res - ] - , testGroup "numAliveNeighbors" - [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $ - \(GenArray (arr :: Array (V2 Word) Bool)) loc -> - let - act :: forall s. ST s Word - act = do - mArr <- thaw @_ @_ @_ @(STUArray s) arr - numAliveNeighborsM mArr loc - res = runST act - in numAliveNeighbors arr loc === res - ] - , testGroup "cloneMArray" - [ testCase "clones the array" $ runST $ - let - go :: forall s. ST s Assertion - go = do - arr <- newArray @(STUArray s) (0 :: Int, 5) (1 :: Int) - arr' <- cloneMArray @_ @(STUArray s) arr - writeArray arr' 0 1234 - x <- readArray arr 0 - pure $ x @?= 1 - in go - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs b/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs deleted file mode 100644 index b681e537efe6..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/MessageSpec.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -module Xanthous.MessageSpec ( main, test ) where - -import Test.Prelude -import Xanthous.Messages -import Data.Aeson -import Text.Mustache -import Control.Lens.Properties - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Messages" - [ testGroup "Message" - [ testGroup "JSON decoding" - [ testCase "Single" - $ decode "\"Test Single Template\"" - @?= Just (Single - $ compileMustacheText "template" "Test Single Template" - ^?! _Right) - , testCase "Choice" - $ decode "[\"Choice 1\", \"Choice 2\"]" - @?= Just - (Choice - [ compileMustacheText "template" "Choice 1" ^?! _Right - , compileMustacheText "template" "Choice 2" ^?! _Right - ]) - ] - ] - , localOption (QuickCheckTests 50) - . localOption (QuickCheckMaxSize 10) - $ testGroup "MessageMap" - [ testGroup "instance Ixed" - [ testProperty "traversal laws" $ \k -> - isTraversal $ ix @MessageMap k - , testCase "preview when exists" $ - let - Right tpl = compileMustacheText "foo" "bar" - msg = Single tpl - mm = Nested $ [("foo", Direct msg)] - in mm ^? ix ["foo"] @?= Just msg - ] - , testGroup "lookupMessage" - [ testProperty "is equivalent to preview ix" $ \msgMap path -> - lookupMessage path msgMap === msgMap ^? ix path - ] - ] - - , testGroup "Messages" - [ testCase "are all valid" $ messages `deepseq` pure () - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs deleted file mode 100644 index 2a3873c3b016..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Messages/TemplateSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Messages.TemplateSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Test.QuickCheck.Instances.Text () -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Function (fix) --------------------------------------------------------------------------------- -import Xanthous.Messages.Template --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Messages.Template" - [ testGroup "parsing" - [ testProperty "literals" $ forAll genLiteral $ \s -> - testParse template s === Right (Literal s) - , parseCase "escaped curlies" - "foo\\{" - $ Literal "foo{" - , parseCase "simple substitution" - "foo {{bar}}" - $ Literal "foo " `Concat` Subst (SubstPath $ "bar" :| []) - , parseCase "substitution with filters" - "foo {{bar | baz}}" - $ Literal "foo " - `Concat` Subst (SubstFilter (SubstPath $ "bar" :| []) - (FilterName "baz")) - , parseCase "substitution with multiple filters" - "foo {{bar | baz | qux}}" - $ Literal "foo " - `Concat` Subst (SubstFilter (SubstFilter (SubstPath $ "bar" :| []) - (FilterName "baz")) - (FilterName "qux")) - , parseCase "two substitutions and a literal" - "{{a}}{{b}}c" - $ Subst (SubstPath $ "a" :| []) - `Concat` Subst (SubstPath $ "b" :| []) - `Concat` Literal "c" - , localOption (QuickCheckTests 10) - $ testProperty "round-trips with ppTemplate" $ \tpl -> - testParse template (ppTemplate tpl) === Right tpl - ] - , testBatch $ monoid @Template mempty - , testGroup "rendering" - [ testProperty "rendering literals renders literally" - $ forAll genLiteral $ \s fs vs -> - render fs vs (Literal s) === Right s - , testProperty "rendering substitutions renders substitutions" - $ forAll genPath $ \ident val fs -> - let tpl = Subst (SubstPath ident) - tvs = varsWith ident val - in render fs tvs tpl === Right val - , testProperty "filters filter" $ forAll genPath - $ \ident filterName filterFn val -> - let tpl = Subst (SubstFilter (SubstPath ident) filterName) - fs = mapFromList [(filterName, filterFn)] - vs = varsWith ident val - in render fs vs tpl === Right (filterFn val) - ] - ] - where - genLiteral = pack . filter (`notElem` ['\\', '{']) <$> arbitrary - parseCase name input expected = - testCase name $ testParse template input @?= Right expected - testParse p = over _Left errorBundlePretty . runParser p "<test>" - genIdentifier = pack @Text <$> listOf1 (elements identifierChars) - identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_'] - - varsWith (p :| []) val = vars [(p, Val val)] - varsWith (phead :| ps) val = vars . pure . (phead ,) . flip fix ps $ - \next pth -> case pth of - [] -> Val val - p : ps' -> nested [(p, next ps')] - - genPath = (:|) <$> genIdentifier <*> listOf genIdentifier - --- diff --git a/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs b/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs deleted file mode 100644 index 3740945877ef..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/OrphansSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE BlockArguments #-} --------------------------------------------------------------------------------- -module Xanthous.OrphansSpec where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Text.Mustache -import Text.Megaparsec (errorBundlePretty) -import Graphics.Vty.Attributes -import qualified Data.Aeson as JSON --------------------------------------------------------------------------------- -import Xanthous.Orphans --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Orphans" - [ localOption (QuickCheckTests 50) - . localOption (QuickCheckMaxSize 10) - $ testGroup "Template" - [ testProperty "ppTemplate / compileMustacheText " \tpl -> - let src = ppTemplate tpl - res :: Either String Template - res = over _Left errorBundlePretty - $ compileMustacheText (templateActual tpl) src - expected = templateCache tpl ^?! at (templateActual tpl) - in - counterexample (unpack src) - $ Right expected === do - (Template actual cache) <- res - maybe (Left "Template not found") Right $ cache ^? at actual - , testProperty "JSON round trip" $ \(tpl :: Template) -> - counterexample (unpack $ ppTemplate tpl) - $ JSON.decode (JSON.encode tpl) === Just tpl - ] - , testGroup "Attr" - [ testProperty "JSON round trip" $ \(attr :: Attr) -> - JSON.decode (JSON.encode attr) === Just attr - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs b/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs deleted file mode 100644 index 187336f08650..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.RandomSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Control.Monad.Random --------------------------------------------------------------------------------- -import Xanthous.Random --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Random" - [ testGroup "chooseSubset" - [ testProperty "chooses a subset" - $ \(l :: [Int]) (Positive (r :: Double)) -> randomTest $ do - ss <- chooseSubset r l - pure $ all (`elem` l) ss - - ] - ] - where - randomTest prop = evalRandT prop . mkStdGen =<< arbitrary diff --git a/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs deleted file mode 100644 index 35ff090b28b9..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Util/GraphSpec.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Xanthous.Util.GraphSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Util.Graph -import Data.Graph.Inductive.Basic -import Data.Graph.Inductive.Graph (labNodes, size, order) -import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive.Arbitrary --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Util.Graph" - [ testGroup "mstSubGraph" - [ testProperty "always produces a subgraph" - $ \(CG _ (graph :: Gr Int Int)) -> - let msg = mstSubGraph $ undir graph - in counterexample (show msg) - $ msg `isSubGraphOf` undir graph - , testProperty "returns a graph with the same nodes" - $ \(CG _ (graph :: Gr Int Int)) -> - let msg = mstSubGraph graph - in counterexample (show msg) - $ labNodes msg === labNodes graph - , testProperty "has nodes - 1 edges" - $ \(CG _ (graph :: Gr Int Int)) -> - order graph > 1 ==> - let msg = mstSubGraph graph - in counterexample (show msg) - $ size msg === order graph - 1 - , testProperty "always produces a simple graph" - $ \(CG _ (graph :: Gr Int Int)) -> - let msg = mstSubGraph graph - in counterexample (show msg) $ isSimple msg - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs deleted file mode 100644 index 61e589280362..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Xanthous.Util.GraphicsSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude hiding (head) --------------------------------------------------------------------------------- -import Data.List (nub, head) -import Data.Set (isSubsetOf) -import Linear.V2 --------------------------------------------------------------------------------- -import Xanthous.Util.Graphics -import Xanthous.Util -import Xanthous.Orphans () --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Util.Graphics" - [ testGroup "circle" - [ testCase "radius 1, origin 2,2" - {- - | | 0 | 1 | 2 | 3 | - |---+---+---+---+---| - | 0 | | | | | - | 1 | | | x | | - | 2 | | x | | x | - | 3 | | | x | | - -} - $ (sort . unique @[] @[_]) (circle @Int (V2 2 2) 1) - @?= [ V2 1 2 - , V2 2 1, V2 2 3 - , V2 3 2 - ] - , testCase "radius 12, origin 0" - $ (sort . nub) (circle @Int 0 12) - @?= (sort . nub) - [ V2 (-12) (-4), V2 (-12) (-3), V2 (-12) (-2), V2 (-12) (-1) - , V2 (-12) 0, V2 (-12) 1, V2 (-12) 2, V2 (-12) 3, V2 (-12) 4 - , V2 (-11) (-6), V2 (-11) (-5), V2 (-11) 5, V2 (-11) 6, V2 (-10) (-7) - , V2 (-10) 7, V2 (-9) (-9), V2 (-9) (-8), V2 (-9) 8, V2 (-9) 9 - , V2 (-8) (-9), V2 (-8) 9, V2 (-7) (-10), V2 (-7) 10, V2 (-6) (-11) - , V2 (-6) 11, V2 (-5) (-11), V2 (-5) 11, V2 (-4) (-12), V2 (-4) 12 - , V2 (-3) (-12), V2 (-3) 12, V2 (-2) (-12), V2 (-2) 12, V2 (-1) (-12) - , V2 (-1) 12, V2 0 (-12), V2 0 12, V2 1 (-12), V2 1 12, V2 2 (-12) - , V2 2 12, V2 3 (-12), V2 3 12, V2 4 (-12), V2 4 12, V2 5 (-11) - , V2 5 11, V2 6 (-11), V2 6 11, V2 7 (-10), V2 7 10, V2 8 (-9), V2 8 9 - , V2 9 (-9), V2 9 (-8), V2 9 8, V2 9 9, V2 10 (-7), V2 10 7 - , V2 11 (-6), V2 11 (-5), V2 11 5, V2 11 6, V2 12 (-4), V2 12 (-3) - , V2 12 (-2), V2 12 (-1), V2 12 0, V2 12 1, V2 12 2, V2 12 3, V2 12 4 - ] - ] - , testGroup "filledCircle" - [ testProperty "is a superset of circle" $ \center radius -> - let circ = circle @Int center radius - filledCirc = filledCircle center radius - in counterexample ( "circle: " <> show circ - <> "\nfilledCircle: " <> show filledCirc) - $ setFromList circ `isSubsetOf` setFromList filledCirc - -- TODO later - -- , testProperty "is always contiguous" $ \center radius -> - -- let filledCirc = filledCircle center radius - -- in counterexample (renderBooleanGraphics filledCirc) $ - ] - , testGroup "line" - [ testProperty "starts and ends at the start and end points" $ \start end -> - let ℓ = line @Int start end - in counterexample ("line: " <> show ℓ) - $ length ℓ > 2 ==> (head ℓ === start) .&&. (head (reverse ℓ) === end) - ] - ] - --------------------------------------------------------------------------------- diff --git a/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs deleted file mode 100644 index fad841043152..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/Util/InflectionSpec.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Xanthous.Util.InflectionSpec (main, test) where - -import Test.Prelude -import Xanthous.Util.Inflection - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Util.Inflection" - [ testGroup "toSentence" - [ testCase "empty" $ toSentence [] @?= "" - , testCase "single" $ toSentence ["x"] @?= "x" - , testCase "two" $ toSentence ["x", "y"] @?= "x and y" - , testCase "three" $ toSentence ["x", "y", "z"] @?= "x, y, and z" - , testCase "four" $ toSentence ["x", "y", "z", "w"] @?= "x, y, z, and w" - ] - ] diff --git a/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs b/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs deleted file mode 100644 index 8538ea5098ba..000000000000 --- a/users/glittershark/xanthous/test/Xanthous/UtilSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Xanthous.UtilSpec (main, test) where - -import Test.Prelude -import Xanthous.Util - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Util" - [ testGroup "smallestNotIn" - [ testCase "examples" $ do - smallestNotIn [7 :: Word, 3, 7] @?= 0 - smallestNotIn [7 :: Word, 0, 1, 3, 7] @?= 2 - , testProperty "returns an element not in the list" $ \(xs :: [Word]) -> - smallestNotIn xs `notElem` xs - , testProperty "pred return is in the list" $ \(xs :: [Word]) -> - let res = smallestNotIn xs - in res /= 0 ==> pred res `elem` xs - , testProperty "ignores order" $ \(xs :: [Word]) -> - forAll (shuffle xs) $ \shuffledXs -> - smallestNotIn xs === smallestNotIn shuffledXs - ] - , testGroup "takeWhileInclusive" - [ testProperty "takeWhileInclusive (const True) ≡ id" - $ \(xs :: [Int]) -> takeWhileInclusive (const True) xs === xs - ] - ] |