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