chore(users): grfn -> aspen

Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>

users/aspen/xanthous/test/Spec.hs

@@ -0,0 +1,61 @@
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import qualified Xanthous.CommandSpec
+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.MemoSpec
+import qualified Xanthous.Data.NestedMapSpec
+import qualified Xanthous.DataSpec
+import qualified Xanthous.Entities.CommonSpec
+import qualified Xanthous.Entities.RawsSpec
+import qualified Xanthous.Entities.RawTypesSpec
+import qualified Xanthous.Entities.CharacterSpec
+import qualified Xanthous.GameSpec
+import qualified Xanthous.Game.StateSpec
+import qualified Xanthous.Game.PromptSpec
+import qualified Xanthous.Generators.Level.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 = defaultMainWithRerun test
+
+test :: TestTree
+test = testGroup "Xanthous"
+  [ Xanthous.CommandSpec.test
+  , Xanthous.Data.EntitiesSpec.test
+  , Xanthous.Data.EntityMap.GraphicsSpec.test
+  , Xanthous.Data.EntityMapSpec.test
+  , Xanthous.Data.LevelsSpec.test
+  , Xanthous.Data.MemoSpec.test
+  , Xanthous.Data.NestedMapSpec.test
+  , Xanthous.DataSpec.test
+  , Xanthous.Entities.CommonSpec.test
+  , Xanthous.Entities.RawsSpec.test
+  , Xanthous.Entities.CharacterSpec.test
+  , Xanthous.Entities.RawTypesSpec.test
+  , Xanthous.GameSpec.test
+  , Xanthous.Game.StateSpec.test
+  , Xanthous.Game.PromptSpec.test
+  , Xanthous.Generators.Level.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
+  ]

users/aspen/xanthous/test/Test/Prelude.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Test.Prelude
+  ( module Xanthous.Prelude
+  , module Test.Tasty
+  , module Test.Tasty.HUnit
+  , module Test.Tasty.QuickCheck
+  , module Test.Tasty.Ingredients.Rerun
+  , module Test.QuickCheck.Classes
+  , testBatch
+  , jsonRoundTrip
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (assert, elements)
+--------------------------------------------------------------------------------
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+import           Test.Tasty.HUnit
+import           Test.Tasty.Ingredients.Rerun
+import           Test.QuickCheck.Classes
+import           Test.QuickCheck.Checkers (TestBatch, EqProp ((=-=)))
+import           Test.QuickCheck.Instances.ByteString ()
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+import           Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+
+testBatch :: TestBatch -> TestTree
+testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests
+
+jsonRoundTrip
+  :: forall a. (ToJSON a, FromJSON a, EqProp a, Arbitrary a, Show a) => TestTree
+jsonRoundTrip = testProperty "JSON round trip" $ \(x :: a) ->
+  JSON.decode (JSON.encode x) =-= Just x

users/aspen/xanthous/test/Xanthous/CommandSpec.hs

@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+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
+  ]

users/aspen/xanthous/test/Xanthous/Data/EntitiesSpec.hs

@@ -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
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Data/EntityCharSpec.hs

@@ -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
+  ]

users/aspen/xanthous/test/Xanthous/Data/EntityMap/GraphicsSpec.hs

@@ -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"

users/aspen/xanthous/test/Xanthous/Data/EntityMapSpec.hs

@@ -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)
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Data/LevelsSpec.hs

@@ -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 (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
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Data/MemoSpec.hs

@@ -0,0 +1,19 @@
+--------------------------------------------------------------------------------
+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
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Data/NestedMapSpec.hs

@@ -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)
+  ]

users/aspen/xanthous/test/Xanthous/DataSpec.hs

@@ -0,0 +1,109 @@
+--------------------------------------------------------------------------------
+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²"
+      ]
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Entities/CharacterSpec.hs

@@ -0,0 +1,24 @@
+{-# 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
+      ]
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Entities/CommonSpec.hs

@@ -0,0 +1,65 @@
+--------------------------------------------------------------------------------
+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)
+      ]
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Entities/RawTypesSpec.hs

@@ -0,0 +1,45 @@
+{-# 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)
+        ]
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Entities/RawsSpec.hs

@@ -0,0 +1,30 @@
+-- |
+
+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)
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Game/PromptSpec.hs

@@ -0,0 +1,19 @@
+--------------------------------------------------------------------------------
+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)]
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Game/StateSpec.hs

@@ -0,0 +1,30 @@
+--------------------------------------------------------------------------------
+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

users/aspen/xanthous/test/Xanthous/GameSpec.hs

@@ -0,0 +1,55 @@
+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
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs

@@ -0,0 +1,127 @@
+{-# 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
+      ]
+  ]

users/aspen/xanthous/test/Xanthous/MessageSpec.hs

@@ -0,0 +1,59 @@
+{-# 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
+      ]
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Messages/TemplateSpec.hs

@@ -0,0 +1,80 @@
+--------------------------------------------------------------------------------
+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
+
+--

users/aspen/xanthous/test/Xanthous/OrphansSpec.hs

@@ -0,0 +1,72 @@
+{-# 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

users/aspen/xanthous/test/Xanthous/RandomSpec.hs

@@ -0,0 +1,45 @@
+--------------------------------------------------------------------------------
+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

users/aspen/xanthous/test/Xanthous/Util/GraphSpec.hs

@@ -0,0 +1,39 @@
+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
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/Util/GraphicsSpec.hs

@@ -0,0 +1,72 @@
+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)
+    ]
+  ]
+
+--------------------------------------------------------------------------------

users/aspen/xanthous/test/Xanthous/Util/InflectionSpec.hs

@@ -0,0 +1,18 @@
+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"
+    ]
+  ]

users/aspen/xanthous/test/Xanthous/UtilSpec.hs

@@ -0,0 +1,46 @@
+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'
+    ]
+  ]