refactor(users/glittershark): Rename to grfn
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>
This commit is contained in:
Griffin Smith
glittershark
parent
968effb5dc
commit
6266c5d32f
362 changed files with 52 additions and 56 deletions
28
users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs
Normal file
28
users/grfn/xanthous/test/Xanthous/Data/EntitiesSpec.hs
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
--------------------------------------------------------------------------------
|
||||
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
|
||||
]
|
||||
]
|
||||
18
users/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs
Normal file
18
users/grfn/xanthous/test/Xanthous/Data/EntityCharSpec.hs
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
--------------------------------------------------------------------------------
|
||||
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
|
||||
]
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
--------------------------------------------------------------------------------
|
||||
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"
|
||||
69
users/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs
Normal file
69
users/grfn/xanthous/test/Xanthous/Data/EntityMapSpec.hs
Normal file
|
|
@ -0,0 +1,69 @@
|
|||
{-# 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)
|
||||
]
|
||||
]
|
||||
66
users/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs
Normal file
66
users/grfn/xanthous/test/Xanthous/Data/LevelsSpec.hs
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
--------------------------------------------------------------------------------
|
||||
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
|
||||
]
|
||||
]
|
||||
20
users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs
Normal file
20
users/grfn/xanthous/test/Xanthous/Data/NestedMapSpec.hs
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
--------------------------------------------------------------------------------
|
||||
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)
|
||||
]
|
||||
Loading…
Add table
Add a link
Reference in a new issue