1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Command
( Command(..)
, Keybinding(..)
, keybindings
, commands
, commandFromKey
, directionFromChar
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Left, Right, Down, try)
--------------------------------------------------------------------------------
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.Util.QuickCheck (GenericArbitrary(..))
--------------------------------------------------------------------------------
data Command
= Quit
| Move !Direction
| StartAutoMove !Direction
| PreviousMessage
| PickUp
| Drop
| Open
| Close
| Wait
| Eat
| Look
| Save
| Read
| ShowInventory
| DescribeInventory
| Wield
| Fire
| GoUp
| GoDown
| Rest
-- | 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 (directionFromChar -> Just dir)) [] = Just $ Move dir
commandFromKey (KChar c) []
| Char.isUpper c
, Just dir <- directionFromChar $ Char.toLower c
= Just $ StartAutoMove dir
commandFromKey k mods = keybindings ^. at keybinding
where keybinding = Keybinding k mods
--------------------------------------------------------------------------------
directionFromChar :: Char -> Maybe Direction
directionFromChar 'h' = Just Left
directionFromChar 'j' = Just Down
directionFromChar 'k' = Just Up
directionFromChar 'l' = Just Right
directionFromChar 'y' = Just UpLeft
directionFromChar 'u' = Just UpRight
directionFromChar 'b' = Just DownLeft
directionFromChar 'n' = Just DownRight
directionFromChar '.' = Just Here
directionFromChar _ = Nothing
|
