diff options
Diffstat (limited to 'users/grfn/xanthous/test/Xanthous')
25 files changed, 0 insertions, 1252 deletions
diff --git a/users/grfn/xanthous/test/Xanthous/CommandSpec.hs b/users/grfn/xanthous/test/Xanthous/CommandSpec.hs deleted file mode 100644 index 13f69a808d..0000000000 --- a/users/grfn/xanthous/test/Xanthous/CommandSpec.hs +++ /dev/null @@ -1,40 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.CommandSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Command --------------------------------------------------------------------------------- -import Data.Aeson (fromJSON, Value(String)) -import qualified Data.Aeson as A -import Graphics.Vty.Input (Key(..), Modifier(..)) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.CommandSpec" - [ testGroup "keybindings" - [ testCase "all are valid" $ keybindings `deepseq` pure () - , testProperty "all non-move commands are bound" $ \cmd -> - let isn'tMove = case cmd of - Move _ -> False - StartAutoMove _ -> False - _ -> True - in isn'tMove ==> member cmd commands - ] - , testGroup "instance FromJSON Keybinding" $ - [ ("q", Keybinding (KChar 'q') []) - , ("<up>", Keybinding KUp []) - , ("<left>", Keybinding KLeft []) - , ("<right>", Keybinding KRight []) - , ("<down>", Keybinding KDown []) - , ("S-q", Keybinding (KChar 'q') [MShift]) - , ("C-S-q", Keybinding (KChar 'q') [MCtrl, MShift]) - , ("m-<UP>", Keybinding KUp [MMeta]) - , ("S", Keybinding (KChar 'S') []) - ] <&> \(s, kb) -> - testCase (fromString $ unpack s <> " -> " <> show kb) - $ fromJSON (String s) @?= A.Success kb - ] diff --git a/users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs deleted file mode 100644 index e403503743..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs deleted file mode 100644 index 9e8024c9d2..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs deleted file mode 100644 index fd37548ce8..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs deleted file mode 100644 index 7c5cad0196..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs deleted file mode 100644 index a752833162..0000000000 --- a/users/grfn/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 (toEnum $ 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 (toEnum $ 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 (toEnum $ 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/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs deleted file mode 100644 index ad81f1984d..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.MemoSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Test.QuickCheck.Instances.Text () --------------------------------------------------------------------------------- -import Xanthous.Data.Memo --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Data.MemoSpec" - [ testGroup "getMemoized" - [ testProperty "when key matches" $ \k v -> - getMemoized @Int @Int k (memoizeWith k v) === Just v - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs deleted file mode 100644 index acf7a67268..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/DataSpec.hs b/users/grfn/xanthous/test/Xanthous/DataSpec.hs deleted file mode 100644 index 9e67505ba9..0000000000 --- a/users/grfn/xanthous/test/Xanthous/DataSpec.hs +++ /dev/null @@ -1,109 +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 - ] - ] - - , testGroup "units" - [ testGroup "unit suffixes" - [ testCase "density" - $ tshow (10000 :: Grams `Per` Cubic Meters) @?= "10000.0 g/m³" - , testCase "volume" - $ tshow (5 :: Cubic Meters) @?= "5.0 m³" - , testCase "area" - $ tshow (5 :: Square Meters) @?= "5.0 m²" - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs deleted file mode 100644 index 734cce1efb..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -Wno-type-defaults #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.CharacterSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Entities.Character -import Xanthous.Util (endoTimes) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.CharacterSpec" - [ testGroup "Knuckles" - [ testBatch $ monoid @Knuckles mempty - , testGroup "damageKnuckles" - [ testCase "caps at 5" $ - let knuckles' = endoTimes 6 damageKnuckles mempty - in _knuckleDamage knuckles' @?= 5 - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs deleted file mode 100644 index a6f8401cf7..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs +++ /dev/null @@ -1,65 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Entities.CommonSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude -import Data.Vector.Lens (toVectorOf) --------------------------------------------------------------------------------- -import Xanthous.Entities.Common --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -newtype OneHand = OneHand Hand - deriving stock Show - -instance Arbitrary OneHand where - arbitrary = OneHand <$> elements [LeftHand, RightHand] - -otherHand :: Hand -> Hand -otherHand LeftHand = RightHand -otherHand RightHand = LeftHand -otherHand BothHands = error "OtherHand BothHands" - -test :: TestTree -test = testGroup "Xanthous.Entities.CommonSpec" - [ testGroup "Inventory" - [ testProperty "items === itemsWithPosition . _2" $ \inv -> - inv ^.. items === inv ^.. itemsWithPosition . _2 - , testGroup "removeItemFromPosition" $ - let rewield w inv = - let (old, inv') = inv & wielded <<.~ w - in inv' & backpack <>~ toVectorOf (wieldedItems . wieldedItem) old - in [ (Backpack, \item -> backpack %~ (item ^. wieldedItem <|)) - , (InHand LeftHand, rewield . inLeftHand) - , (InHand RightHand, rewield . inRightHand) - , (InHand BothHands, rewield . review doubleHanded) - ] <&> \(pos, addItem) -> - testProperty (show pos) $ \inv item -> - let inv' = addItem item inv - inv'' = removeItemFromPosition pos (item ^. wieldedItem) inv' - in inv'' ^.. items === inv ^.. items - ] - , testGroup "Wielded items" - [ testGroup "wieldInHand" - [ testProperty "puts the item in the hand" $ \w hand item -> - let (_, w') = wieldInHand hand item w - in itemsInHand hand w' === [item] - , testProperty "returns items in both hands when wielding double-handed" - $ \lh rh newItem -> - let w = Hands (Just lh) (Just rh) - (prevItems, _) = wieldInHand BothHands newItem w - in prevItems === [lh, rh] - , testProperty "wielding in one hand leaves the item in the other hand" - $ \(OneHand h) existingItem newItem -> - let (_, w) = wieldInHand h existingItem nothingWielded - (prevItems, w') = wieldInHand (otherHand h) newItem w - in prevItems === [] - .&&. sort (w' ^.. wieldedItems) === sort [existingItem, newItem] - , testProperty "always leaves the same items overall" $ \w hand item -> - let (prevItems, w') = wieldInHand hand item w - in sort (prevItems <> (w' ^.. wieldedItems)) - === sort (item : w ^.. wieldedItems) - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs deleted file mode 100644 index e23f7faba3..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.RawTypesSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Data.Interval (Extended(..), (<=..<=)) --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.RawTypesSpec" - [ testGroup "CreatureGenerateParams" - [ testGroup "Ord laws" - [ testProperty "comparability" $ \(a :: CreatureGenerateParams) b -> - a <= b || b <= a - , testProperty "transitivity" $ \(a :: CreatureGenerateParams) b c -> - a <= b && b <= c ==> a <= c - , testProperty "reflexivity" $ \(a :: CreatureGenerateParams) -> - a <= a - , testProperty "antisymmetry" $ \(a :: CreatureGenerateParams) b -> - (a <= b && b <= a) == (a == b) - ] - , testGroup "canGenerate" $ - let makeParams minB maxB = - let _levelRange = maybe NegInf Finite minB <=..<= maybe PosInf Finite maxB - _equippedItem = Nothing - in CreatureGenerateParams {..} - in - [ testProperty "no bounds" $ \level -> - let gps = makeParams Nothing Nothing - in canGenerate level gps - , testProperty "min bound" $ \level minB -> - let gps = makeParams (Just minB) Nothing - in canGenerate level gps === (level >= minB) - , testProperty "max bound" $ \level maxB -> - let gps = makeParams Nothing (Just maxB) - in canGenerate level gps === (level <= maxB) - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs deleted file mode 100644 index b6c80be51b..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | - -module Xanthous.Entities.RawsSpec (main, test) where - -import Test.Prelude -import Xanthous.Entities.Raws -import Xanthous.Entities.RawTypes - (_Creature, entityName, generateParams, HasEquippedItem (equippedItem)) - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Entities.Raws" - [ testGroup "raws" - [ testCase "are all valid" $ raws `deepseq` pure () - , testCase "all CreatureEquippedItems reference existent entity names" $ - let notFound - = raws - ^.. folded - . _Creature - . generateParams - . _Just - . equippedItem - . _Just - . entityName - . filtered (isNothing . raw) - in null notFound @? ("Some entities weren't found: " <> show notFound) - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs deleted file mode 100644 index d7a3df4aca..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Game.PromptSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Game.Prompt --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Game.PromptSpec" - [ testGroup "mkMenuItems" - [ testCase "with duplicate items" - $ mkMenuItems @[_] [('a', MenuOption @Int "a" 1), ('a', MenuOption "a" 2)] - @?= mapFromList [('a', MenuOption "a" 1), ('b', MenuOption "a" 2)] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs deleted file mode 100644 index 34584f73b2..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Game.StateSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Xanthous.Game.State -import Xanthous.Entities.Raws (raws) -import Xanthous.Generators.Level.LevelContents (entityFromRaw) -import Control.Monad.Random (evalRandT) -import System.Random (getStdGen) --------------------------------------------------------------------------------- - -main :: IO () -main = defaultMain test - -test :: TestTree -test = testGroup "Xanthous.Game.StateSpec" - [ testGroup "entityTypeName" - [ testCase "for a creature" $ do - let gormlakRaw = raws ^?! ix "gormlak" - creature <- runRand $ entityFromRaw gormlakRaw - entityTypeName creature @?= "Creature" - , testCase "for an item" $ do - let stickRaw = raws ^?! ix "stick" - item <- runRand $ entityFromRaw stickRaw - entityTypeName item @?= "Item" - ] - ] - where - runRand x = evalRandT x =<< getStdGen diff --git a/users/grfn/xanthous/test/Xanthous/GameSpec.hs b/users/grfn/xanthous/test/Xanthous/GameSpec.hs deleted file mode 100644 index 2fa8527d0e..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs deleted file mode 100644 index b53c657f75..0000000000 --- a/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE PackageImports #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.Level.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, array) -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.Level.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 - , testCase "on the outer x edge" $ - let act :: forall s. ST s Word - act = do - cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - numAliveNeighborsM cells (V2 0 1) - res = runST act - in res @?= 7 - , testCase "on the outer y edge" $ - let act :: forall s. ST s Word - act = do - cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - numAliveNeighborsM cells (V2 1 0) - res = runST act - in res @?= 6 - ] - , 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 - , testCase "on the outer x edge" $ - let cells = - array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - in numAliveNeighbors cells (V2 0 1) @?= 7 - , testCase "on the outer y edge" $ - let cells = - array @Array @Bool @(V2 Word) - (V2 0 0, V2 2 2) - [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) - , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) - , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) - ] - in numAliveNeighbors cells (V2 1 0) @?= 6 - ] - , 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/grfn/xanthous/test/Xanthous/MessageSpec.hs b/users/grfn/xanthous/test/Xanthous/MessageSpec.hs deleted file mode 100644 index 2068e338ba..0000000000 --- a/users/grfn/xanthous/test/Xanthous/MessageSpec.hs +++ /dev/null @@ -1,59 +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 () - ] - - , testGroup "Template" - [ testGroup "eq" - [ testProperty "reflexive" $ \(tpl :: Template) -> tpl == tpl - ] - ] - ] diff --git a/users/grfn/xanthous/test/Xanthous/Messages/TemplateSpec.hs b/users/grfn/xanthous/test/Xanthous/Messages/TemplateSpec.hs deleted file mode 100644 index 2a3873c3b0..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/OrphansSpec.hs b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs deleted file mode 100644 index 0d800e8a91..0000000000 --- a/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE OverloadedLists #-} --------------------------------------------------------------------------------- -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 Data.Interval (Interval, (<=..<=), (<=..<), (<..<=)) -import Data.Aeson ( ToJSON(toJSON), object, Value(Array) ) -import Data.Aeson.Types (fromJSON) -import Data.IntegerInterval (Extended(Finite)) --------------------------------------------------------------------------------- -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" - [ jsonRoundTrip @Attr ] - , testGroup "Extended" - [ jsonRoundTrip @(Extended Int) ] - , testGroup "Interval" - [ testGroup "JSON" - [ jsonRoundTrip @(Interval Int) - , testCase "parses a single value as a length-1 interval" $ - getSuccess (fromJSON $ toJSON (1 :: Int)) - @?= Just (Finite (1 :: Int) <=..<= Finite 1) - , testCase "parses a pair of values as a single-ended interval" $ - getSuccess (fromJSON $ toJSON ([1, 2] :: [Int])) - @?= Just (Finite (1 :: Int) <=..< Finite (2 :: Int)) - , testCase "parses the full included/excluded syntax" $ - getSuccess (fromJSON $ Array [ object [ "Excluded" JSON..= (1 :: Int) ] - , object [ "Included" JSON..= (4 :: Int) ] - ]) - @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int)) - , testCase "parses open/closed as aliases" $ - getSuccess (fromJSON $ Array [ object [ "Open" JSON..= (1 :: Int) ] - , object [ "Closed" JSON..= (4 :: Int) ] - ]) - @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int)) - ] - ] - ] - where - getSuccess :: JSON.Result a -> Maybe a - getSuccess (JSON.Error _) = Nothing - getSuccess (JSON.Success r) = Just r diff --git a/users/grfn/xanthous/test/Xanthous/RandomSpec.hs b/users/grfn/xanthous/test/Xanthous/RandomSpec.hs deleted file mode 100644 index c88bd95629..0000000000 --- a/users/grfn/xanthous/test/Xanthous/RandomSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.RandomSpec (main, test) where --------------------------------------------------------------------------------- -import Test.Prelude --------------------------------------------------------------------------------- -import Control.Monad.Random --------------------------------------------------------------------------------- -import Xanthous.Random -import Xanthous.Orphans () -import qualified Data.Interval as Interval -import Data.Interval (Interval, Extended (Finite), (<=..<=)) --------------------------------------------------------------------------------- - -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 - ] - , testGroup "chooseRange" - [ testProperty "chooses in the range" - $ \(rng :: Interval Int) -> - not (Interval.null rng) - ==> randomTest ( do - chooseRange rng >>= \case - Just r -> pure - . counterexample (show r) - $ r `Interval.member` rng - Nothing -> pure $ property Discard - ) - , testProperty "nonEmpty range is never empty" - $ \ (lower :: Int) (NonZero diff) -> randomTest $ do - let upper = lower + diff - r <- chooseRange (Finite lower <=..<= Finite upper) - pure $ isJust r - - ] - ] - where - randomTest prop = evalRandT prop . mkStdGen =<< arbitrary diff --git a/users/grfn/xanthous/test/Xanthous/Util/GraphSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/GraphSpec.hs deleted file mode 100644 index 35ff090b28..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/GraphicsSpec.hs deleted file mode 100644 index 61e5892803..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/Util/InflectionSpec.hs b/users/grfn/xanthous/test/Xanthous/Util/InflectionSpec.hs deleted file mode 100644 index fad8410431..0000000000 --- a/users/grfn/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/grfn/xanthous/test/Xanthous/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs deleted file mode 100644 index 684a03b2c7..0000000000 --- a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Xanthous.UtilSpec (main, test) where - -import Test.Prelude -import Xanthous.Util -import Control.Monad.State.Lazy (execState) - -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 - ] - , testGroup "endoTimes" - [ testCase "endoTimes 4 succ 5" - $ endoTimes (4 :: Int) succ (5 :: Int) @?= 9 - ] - , testGroup "modifyKL" - [ testCase "_1 += 1" - $ execState (modifyKL _1 $ pure . succ) (1 :: Int, 2 :: Int) @?= (2, 2) - ] - , testGroup "removeFirst" - [ testCase "example" $ - removeFirst @[Int] (> 5) [1..10] @?= [1, 2, 3, 4, 5, 7, 8, 9, 10] - , testProperty "the result is the right length" $ \(xs :: [Int]) p -> - length (removeFirst p xs) `elem` [length xs, length xs - 1] - ] - , testGroup "AlphaChar" - [ testCase "succ 'z'" $ succ (AlphaChar 'z') @?= AlphaChar 'A' - ] - ] |