diff options
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Command.hs | 115 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Orphans.hs | 6 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/keybindings.yaml | 21 | ||||
| -rw-r--r-- | users/grfn/xanthous/test/Spec.hs | 4 | ||||
| -rw-r--r-- | users/grfn/xanthous/test/Xanthous/CommandSpec.hs | 40 | ||||
| -rw-r--r-- | users/grfn/xanthous/xanthous.cabal | 5 |
6 files changed, 154 insertions, 37 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs index 187e5c16d7da..30ed86ee4041 100644 --- a/users/grfn/xanthous/src/Xanthous/Command.hs +++ b/users/grfn/xanthous/src/Xanthous/Command.hs @@ -1,18 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -module Xanthous.Command where +module Xanthous.Command + ( Command(..) + , Keybinding(..) + , keybindings + , commands + , commandFromKey + , directionFromChar + ) where -------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Left, Right, Down) +import Xanthous.Prelude hiding (Left, Right, Down, try) -------------------------------------------------------------------------------- -import Graphics.Vty.Input (Key(..), Modifier(..)) +import Graphics.Vty.Input (Key(..), Modifier(..)) import qualified Data.Char as Char +import Data.Aeson (FromJSON (parseJSON), FromJSONKey, FromJSONKeyFunction (FromJSONKeyTextParser)) +import qualified Data.Aeson as A +import Data.Aeson.Generic.DerivingVia +import Text.Megaparsec (Parsec, errorBundlePretty, parse, eof, try) +import Text.Megaparsec.Char (string', char', printChar) +import Data.FileEmbed (embedFile) +import qualified Data.Yaml as Yaml +import Test.QuickCheck.Arbitrary +import Data.Aeson.Types (Parser) -------------------------------------------------------------------------------- -import Xanthous.Data (Direction(..)) +import Xanthous.Data (Direction(..)) +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -------------------------------------------------------------------------------- data Command = Quit - | Move Direction - | StartAutoMove Direction + | Move !Direction + | StartAutoMove !Direction | PreviousMessage | PickUp | Drop @@ -33,41 +51,70 @@ data Command -- | TODO replace with `:` commands | ToggleRevealAll + deriving stock (Show, Eq, Generic) + deriving anyclass (Hashable, NFData) + deriving Arbitrary via GenericArbitrary Command + deriving (FromJSON) + via WithOptions '[ SumEnc UntaggedVal ] + Command + +-------------------------------------------------------------------------------- + +data Keybinding = Keybinding !Key ![Modifier] + deriving stock (Show, Eq, Generic) + deriving anyclass (Hashable, NFData) + +parseKeybindingFromText :: Text -> Parser Keybinding +parseKeybindingFromText + = either (fail . errorBundlePretty) pure + . parse keybinding "<JSON>" + where + key :: Parsec Void Text Key + key = KUp <$ string' "<up>" + <|> KDown <$ string' "<down>" + <|> KLeft <$ string' "<left>" + <|> KRight <$ string' "<right>" + <|> KChar <$> printChar + + modifier :: Parsec Void Text Modifier + modifier = modf <* char' '-' + where + modf = MAlt <$ char' 'a' + <|> MMeta <$ char' 'm' + <|> MCtrl <$ char' 'c' + <|> MShift <$ char' 's' + + keybinding :: Parsec Void Text Keybinding + keybinding = do + mods <- many (try modifier) + k <- key + eof + pure $ Keybinding k mods + +instance FromJSON Keybinding where + parseJSON = A.withText "Keybinding" parseKeybindingFromText + +instance FromJSONKey Keybinding where + fromJSONKey = FromJSONKeyTextParser parseKeybindingFromText + +rawKeybindings :: ByteString +rawKeybindings = $(embedFile "src/Xanthous/keybindings.yaml") + +keybindings :: HashMap Keybinding Command +keybindings = either (error . Yaml.prettyPrintParseException) id + $ Yaml.decodeEither' rawKeybindings + +commands :: HashMap Command Keybinding +commands = mapFromList . map swap . itoList $ keybindings commandFromKey :: Key -> [Modifier] -> Maybe Command -commandFromKey (KChar 'q') [] = Just Quit -commandFromKey (KChar '.') [] = Just Wait commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir commandFromKey (KChar c) [] | Char.isUpper c , Just dir <- directionFromChar $ Char.toLower c = Just $ StartAutoMove dir -commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage -commandFromKey (KChar ',') [] = Just PickUp -commandFromKey (KChar 'd') [] = Just Drop -commandFromKey (KChar 'o') [] = Just Open -commandFromKey (KChar 'c') [] = Just Close -commandFromKey (KChar ';') [] = Just Look -commandFromKey (KChar 'e') [] = Just Eat -commandFromKey (KChar 'S') [] = Just Save -commandFromKey (KChar 'r') [] = Just Read -commandFromKey (KChar 'i') [] = Just ShowInventory -commandFromKey (KChar 'I') [] = Just DescribeInventory -commandFromKey (KChar 'w') [] = Just Wield -commandFromKey (KChar 'f') [] = Just Fire -commandFromKey (KChar '<') [] = Just GoUp -commandFromKey (KChar '>') [] = Just GoDown -commandFromKey (KChar 'R') [] = Just Rest - -commandFromKey KUp [] = Just $ Move Up -commandFromKey KDown [] = Just $ Move Down -commandFromKey KLeft [] = Just $ Move Left -commandFromKey KRight [] = Just $ Move Right - --- DEBUG COMMANDS -- -commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll - -commandFromKey _ _ = Nothing +commandFromKey k mods = keybindings ^. at keybinding + where keybinding = Keybinding k mods -------------------------------------------------------------------------------- diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs index a8274bf0aa44..385873e7b464 100644 --- a/users/grfn/xanthous/src/Xanthous/Orphans.hs +++ b/users/grfn/xanthous/src/Xanthous/Orphans.hs @@ -38,6 +38,7 @@ import Test.QuickCheck.Checkers (EqProp ((=-=))) import Xanthous.Util.JSON import Xanthous.Util.QuickCheck import Xanthous.Util (EqEqProp(EqEqProp)) +import qualified Graphics.Vty.Input.Events -------------------------------------------------------------------------------- instance forall s a. @@ -305,6 +306,11 @@ deriving stock instance Ord Color deriving stock instance Ord a => Ord (MaybeDefault a) deriving stock instance Ord Attr +deriving anyclass instance Hashable Graphics.Vty.Input.Events.Key +deriving anyclass instance NFData Graphics.Vty.Input.Events.Key +deriving anyclass instance Hashable Graphics.Vty.Input.Events.Modifier +deriving anyclass instance NFData Graphics.Vty.Input.Events.Modifier + -------------------------------------------------------------------------------- instance (SemiSequence a, Arbitrary (Element a), Arbitrary a) diff --git a/users/grfn/xanthous/src/Xanthous/keybindings.yaml b/users/grfn/xanthous/src/Xanthous/keybindings.yaml new file mode 100644 index 000000000000..29a52d27985f --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/keybindings.yaml @@ -0,0 +1,21 @@ +q: Quit +.: Wait +C-p: PreviousMessage +',': PickUp +d: Drop +o: Open +c: Close +;: Look +e: Eat +S: Save +r: Read +i: ShowInventory +I: DescribeInventory +w: Wield +f: Fire +'<': GoUp +'>': GoDown +R: Rest + +# Debug commands +M-r: ToggleRevealAll diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs index 64c10cf21e20..51758d6a25ec 100644 --- a/users/grfn/xanthous/test/Spec.hs +++ b/users/grfn/xanthous/test/Spec.hs @@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- import Test.Prelude -------------------------------------------------------------------------------- +import qualified Xanthous.CommandSpec import qualified Xanthous.Data.EntitiesSpec import qualified Xanthous.Data.EntityCharSpec import qualified Xanthous.Data.EntityMap.GraphicsSpec @@ -32,7 +33,8 @@ main = defaultMainWithRerun test test :: TestTree test = testGroup "Xanthous" - [ Xanthous.Data.EntitiesSpec.test + [ Xanthous.CommandSpec.test + , Xanthous.Data.EntitiesSpec.test , Xanthous.Data.EntityMap.GraphicsSpec.test , Xanthous.Data.EntityMapSpec.test , Xanthous.Data.LevelsSpec.test diff --git a/users/grfn/xanthous/test/Xanthous/CommandSpec.hs b/users/grfn/xanthous/test/Xanthous/CommandSpec.hs new file mode 100644 index 000000000000..13f69a808d02 --- /dev/null +++ b/users/grfn/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 + ] diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal index 987e1f48f693..1555f728ace9 100644 --- a/users/grfn/xanthous/xanthous.cabal +++ b/users/grfn/xanthous/xanthous.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack -- --- hash: 8cae8550487b6092c18c82a0dc29bf22980d416771c66f6fca3e151875c66495 +-- hash: 107b223a62633bc51425e8f9d5ab489a7a47464953a81ca693efb496c41f1aa3 name: xanthous version: 0.1.0.0 @@ -293,6 +293,7 @@ test-suite test main-is: Spec.hs other-modules: Test.Prelude + Xanthous.CommandSpec Xanthous.Data.EntitiesSpec Xanthous.Data.EntityCharSpec Xanthous.Data.EntityMap.GraphicsSpec |