diff options
Diffstat (limited to 'users/grfn')
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Prompt.hs | 5 | ||||
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Util.hs | 34 | ||||
-rw-r--r-- | users/grfn/xanthous/test/Spec.hs | 2 | ||||
-rw-r--r-- | users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs | 19 | ||||
-rw-r--r-- | users/grfn/xanthous/test/Xanthous/UtilSpec.hs | 3 | ||||
-rw-r--r-- | users/grfn/xanthous/xanthous.cabal | 3 |
6 files changed, 63 insertions, 3 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs index 30b5fe7545e0..fa4c3903deb1 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs @@ -28,7 +28,8 @@ import Brick.Widgets.Edit (Editor, editorText, getEditContents) import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic -------------------------------------------------------------------------------- -import Xanthous.Util (smallestNotIn) +-------------------------------------------------------------------------------- +import Xanthous.Util (smallestNotIn, AlphaChar (..)) import Xanthous.Data (Direction, Position) import Xanthous.Data.App (ResourceName) import qualified Xanthous.Data.App as Resource @@ -175,7 +176,7 @@ mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a)) -> Map Char (MenuOption a) mkMenuItems = flip foldl' mempty $ \items (chr, option) -> let chr' = if has (ix chr) items - then smallestNotIn $ keys items + then getAlphaChar . smallestNotIn . map AlphaChar $ keys items else chr in items & at chr' ?~ option diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs index d3e8cdc30138..2f9606b29c50 100644 --- a/users/grfn/xanthous/src/Xanthous/Util.hs +++ b/users/grfn/xanthous/src/Xanthous/Util.hs @@ -38,6 +38,9 @@ module Xanthous.Util -- * Type-level programming utils , KnownBool(..) + + -- * + , AlphaChar(..) ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (foldr) @@ -299,3 +302,34 @@ modifyK k = get >>= k >>= put -- @@ modifyKL :: MonadState s m => LensLike m s s a b -> (a -> m b) -> m () modifyKL l k = get >>= traverseOf l k >>= put + +-------------------------------------------------------------------------------- + +-- | A newtype wrapper around 'Char' whose 'Enum' and 'Bounded' instances only +-- include the characters @[a-zA-Z]@ +-- +-- >>> succ (AlphaChar 'z') +-- 'A' +newtype AlphaChar = AlphaChar { getAlphaChar :: Char } + deriving stock Show + deriving (Eq, Ord) via Char + +instance Enum AlphaChar where + toEnum n + | between 0 25 n + = AlphaChar . toEnum $ n + fromEnum 'a' + | between 26 51 n + = AlphaChar . toEnum $ n - 26 + fromEnum 'A' + | otherwise + = error $ "Tag " <> show n <> " out of range [0, 51] for enum AlphaChar" + fromEnum (AlphaChar chr) + | between 'a' 'z' chr + = fromEnum chr - fromEnum 'a' + | between 'A' 'Z' chr + = fromEnum chr - fromEnum 'A' + | otherwise + = error $ "Invalid value for alpha char: " <> show chr + +instance Bounded AlphaChar where + minBound = AlphaChar 'a' + maxBound = AlphaChar 'Z' diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs index 85f49fd07c91..dfecfbdd21c5 100644 --- a/users/grfn/xanthous/test/Spec.hs +++ b/users/grfn/xanthous/test/Spec.hs @@ -13,6 +13,7 @@ import qualified Xanthous.Entities.RawsSpec 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 @@ -40,6 +41,7 @@ test = testGroup "Xanthous" , Xanthous.Entities.CharacterSpec.test , Xanthous.GameSpec.test , Xanthous.Game.StateSpec.test + , Xanthous.Game.PromptSpec.test , Xanthous.Generators.Level.UtilSpec.test , Xanthous.MessageSpec.test , Xanthous.Messages.TemplateSpec.test diff --git a/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/PromptSpec.hs new file mode 100644 index 000000000000..d7a3df4acafa --- /dev/null +++ b/users/grfn/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)] + ] + ] diff --git a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs index 0d6b718bc351..684a03b2c7a0 100644 --- a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs @@ -40,4 +40,7 @@ test = testGroup "Xanthous.Util" , 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' + ] ] diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal index baa09fab3e36..45f85616b6d7 100644 --- a/users/grfn/xanthous/xanthous.cabal +++ b/users/grfn/xanthous/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: fdfa821ad291b11a2d7a7ee9cc38d7980a9b1f494b77216b141d3424168d621d +-- hash: 761fd1d1a9f9f9fdf8e14e56922558f7968401c879dcb95ca697dab03d1e9eec name: xanthous version: 0.1.0.0 @@ -359,6 +359,7 @@ test-suite test Xanthous.DataSpec Xanthous.Entities.CharacterSpec Xanthous.Entities.RawsSpec + Xanthous.Game.PromptSpec Xanthous.Game.StateSpec Xanthous.GameSpec Xanthous.Generators.Level.UtilSpec |